perm filename UCILSP.MAC[LSP,SYS] blob
sn#046093 filedate 1973-06-05 generic text, type T, neo UTF8
00100 SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
00200 TITLE LISP INTERPRETER
00300 TWOSEG
00400 ;SYSPRG==667 ;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
00500 ;SYSPN==2 ;SAME HERE
00550 SYSPRG==654351 ;***
00575 SYSPN==6744 ;***
00600 IFNDEF SYSPRG,<SYSPRG==0
00700 SYSPN==0>
00800 ;ALVINE==1 ;1 FOR ALVINE, 0 FOR NO ALVINE
00900 IFNDEF ALVINE,<ALVINE==0>
01000 ;HASH==1 ;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
01100 IFNDEF HASH,<HASH==0>
01200 ;STPGAP==1 ;1 FOR STOPGAP, 0 TO DELETE IT
01300 IFNDEF STPGAP,<STPGAP==0>
01400 IF1,<PURGE CDR,DF>
01410 STANSW==1 ;1 FOR STANFORD, 0 FOR CHRISTIANS
01420 IFNDEF STANSW,<STANSW==0>
01430
01500 MLON
01600 INUMIN=377777
01700 INUM0=<INUMIN+777777>/2
01800 BCKETS==177
01900 IFE SYSPRG,<DEFINE SYSDEV <SIXBIT /SYS/>>
02000 IFN SYSPRG,<DEFINE SYSDEV <SIXBIT /DSK/>>
02100 DEFINE SYSNAM <SIXBIT /LISP/>
02200
02300 ;accumulator definitions
02400 ;`sacred' means sacred to the interpreter
02500 ;`marked' means marked from by the garbage collector
02600 ;`protected' means protected during garbage collection
02700
02800 NIL=0 ;sacred, marked, protected ;atom head of NIL
02900 A=1 ;marked, protected ;results of functions and first arg of subrs
03000 B=A+1 ;marked, protected ;second arg of subrs
03100 C=B+1 ;marked, protected ;third arg of subrs
03200 AR1=4 ;marked, protected ;fourth arg of subrs
03300 AR2A=5 ;marked, protected ;fifth arg of subrs
03400 T=6 ;marked, protected ;minus number of args in LSUBR call
03500 TT=7 ;marked, protected
03600 REL=10 ;marked, protected
03700 S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
03800 D=12
03900 R=13 ;protected
04000 P=14 ;sacred, protected ;regular push down stack pointer
04100 F=15 ;sacred ;free storage list pointer
04200 FF=16 ;sacred ;full word list pointer
04300 SP=17 ;sacred, protected ;special pushdown stack pointer
04400
04500 NACS==5 ;number of argument acs
04600
04700 X==0 ;X indicates impure (modified) code locations
04800 TEN==↑D10
04900
05000 ;UUO definitions
05100 ;UUOs used to call functions from compiled code
05200 ;the number of arguments is given by the ac field
05300 ;the address is a pointer either to the function
05400 ;name or the code of the function
05500 OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
05600 OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
05700 OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
05800 OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
05900 ;error UUOs
06000
06100 OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
06200 OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
06300 OPDEF ERR3 [3B8] ;ill. mem. ref.
06400 OPDEF STRTIP [4B8] ;print error message and continue
06500 ;system UUOs
06600
06700 OPDEF TTYUUO [51B8]
06800 OPDEF INCHRW [TTYUUO 0,]
06900 OPDEF OUTCHR [TTYUUO 1,]
07000 OPDEF OUTSTR [TTYUUO 3,]
07100 OPDEF INCHWL [TTYUUO 4,]
07200 OPDEF INCHSL [TTYUUO 5,]
07300 OPDEF CLRBFI [TTYUUO 11,]
07400 OPDEF SKPINC [TTYUUO 13,]
07500 OPDEF TALK [PUSHJ P,TTYCLR] ;this is to turn off control O.
07600 ;when ttyser lets you do this
07700 ;easily, change me
07800
07900 ;I/O bits and constants
08000 TTYLL==105 ;teletype linelength
08100 LPTLL==160 ;line printer linelength
08200 MLIOB==203 ;max length of I/O buffer
08300 NIOB==2 ;no of I/O buffers per device
08400 NIOCH==17 ;number of I/O channels
08500 FSTCH==1 ;first I/O channel
08600 TTCH==0 ;teletype I/O channel
08700 BLKSIZE==NIOB*MLIOB+COUNT+1
08800 INB==2
08900 OUTB==1
09000 AVLB==40
09100 DIRB==4
09200
09300 ;special ASCII characters
09400 ALTMOD==175
09500 SPACE==40 ;space
09600 IGCRLF==31 ;ignored cr-lf
09700 RUBOUT==177
09800 LF==12
09900 CR==15
10000 TAB==11
10100 BELL==7
10200 DBLQT==42 ;double quote "
10300
10400 ;byte pointer field definitions
10500 ACFLD==14 ;ac field
10600 XFLD==21 ;index field
10700 OPFLD==10 ;opcode field
10800 ADRFLD==43 ;adress field
10900
11000 ;external and internal symbols
11100
11200 EXTERNAL JOB41 ;instruction to be executed on UUO
11300 EXTERNAL JOBAPR ;address of APR interupt routines
11400 EXTERNAL JOBCNI ;interupt condition flags
11500 EXTERNAL JOBFF ;first location beyond program
11600 EXTERNAL JOBREL ;address of last legal instruction in core image
11700 EXTERNAL JOBREN ;reentry address
11800 EXTERNAL JOBSA ;starting address
11900 EXTERNAL JOBSYM ;address of symbol table
12000 EXTERNAL JOBTPC ;program counter at time of interupt
12100 EXTERNAL JOBUUO ;uuo is put here with effective address computed
12200 EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
12300 EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
12400
12500
12600 ;apr flags
12700 PDOV==200000 ;push down list overflow
12800 MPV==20000 ;memory protection violation
12900 NXM==10000 ;non-existant memory referenced
13000 APRFLG==PDOV+MPV+NXM ;any of the above
13100
13200 ;RE-ENTER CONTROL CHARACTERS
13300 CNTLH==10
13400 CNTLE==5
13500 CNTLB==2
13600 CNTLZ==32
13700 CNTLG==7
13800
13900 ;system uuos
14000 APRINI==16
14100 RESET==0
14200 STIME==27
14300 DEVCHR==4
14400 EXIT==12
14500 CORE==11
14600 SETUWP==36
14700 GETSEG==40
14800 ;REMOTE MACRO
14900
15000 DEFINE REMOTE (TX)
15100 < HERE1 <TX>>
15200
15300 DEFINE HERE1 (NEW,OLD,%G)
15400 < DEFINE %G
15500 < NEW>
15600 DEFINE REMOTE (TX)
15700 < HERE1 <TX>,<OLD
15800 %G
15900 >>>
16000 DEFINE HERE
16100 < DEFINE HERE1 (XX,YY)
16200 < YY>
16300 REMOTE>
16400 SALL
16500 SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
16600 PAGE
16700
16800 SHRST==400000
16900 RELOC SHRST
17000 REMOTE<
17100 LISPGO: SKIPE GCFLG ;$$CHECK FO GARBAGE COLLECTION
17200 PUSHJ P,GCING ;$$QUEUE THE REQUEST
17300 CAME 0,STNIL ;$$UNBIND STACK IF REGS LOOK OK
17400 JRST GETHGH ;GO GET HIGH SEGMENT
17500 MOVE B,SC2
17600 PUSHJ P,UBD ;$$UNBIND STACK
17700 JRST STRT ;go to re-allocator
17800 GETHGH: CALLI RESET
17900 MOVSI A,1
18000 IFE STANSW,< CALLI A,CORE ;ELIMINATE ANY OLD HIGH SEGS.
18005 HALT >
18010 ;*** IFN STANSW,< CALLI A,400015
18055 ;*** HALT>
18200 ;*** MOVEI A,HGHDAT
18300 ;*** CALLI A,GETSEG ;GET THE PROPER HIGH SEG
18400 ;*** HALT
18500 MOVEI A,DEBUGO ;SET THE REE ADDRESS
18600 HRRM A,JOBREN
18700 JRST STRT ;GO TO ALLOCATE STORAGE
18800 HGHDAT: SYSDEV
18900 SYSNAM
19000 0
19100 0
19200 XWD SYSPRG,SYSPN
19300 0>
19400
19500
19600 DDT: SETOM ERINT ;$$SET CONTROL H WITHOUT GOING THRU REE
19700 JRST @JOBOPC ;$$AND CONTINUE
19800
19900 DEBUGO: SKIPE GCFLG# ;CHECK GARBASE COLLECT.
20000 PUSHJ P,GCING ;QUEUE INTERRUPT
20100 INCHRW 0 ;READ THE CONTROL CHARACTER
20200 CAIN 0,CNTLH
20300 JRST [MOVE 0,STNIL
20400 JRST DDT]
20500 CAIN 0,CNTLE
20600 JRST [MOVE 0,STNIL
20700 MOVEI 1,NIL
20800 JRST ERR]
20900 CAIN 0,CNTLB
21000 JRST [MOVE 0,STNIL
21100 SETOM ERINT
21200 PUSHJ P,SPDLPT
21300 PUSHJ P,SPREDO
21400 JRST LSPRET]
21500 CAIN 0,CNTLZ
21600 JRST [MOVE 0,STNIL
21700 JRST LSPRET]
21800 CAIN 0,CNTLG
21900 JRST [MOVE 0,STNIL
22000 JRST RERX]
22100 JRST DEBUGO+2 ;NOT A CONTROL CHARACTER
22200 ;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
22300
22400 START: CALLI RESET ;random initializations for lisp interupts
22500 MOVE [JSR UUOH]
22600 MOVEM JOB41
22700 MOVEI APRINT
22800 MOVEM JOBAPR
22900 MOVEI APRFLG
23000 CALLI APRINI
23100 SETZM GCFLG
23200 HRRZI 17,1
23300 IFN ALVINE,<SETZB 0,PSAV1>
23400 IFE ALVINE,<SETZ 0,>
23500 BLT 17,17 ;clear acs
23600 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
23700 LSPRT1: SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
23800 SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
23900 MOVEI A,INUM0
24000 MOVEM A,BINDNT(S)
24100 SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
24200 SETOM ERRSW ;print error messages
24300 CLEARM ERRTN# ;return to top level on errors
24400 SETOM PRVCNT# ;initialize counter for errio
24500 MOVE P,C2# ;initial reg pdl ptr
24600 MOVE SP,SC2# ;initial spec pdl ptr
24700
24800
24900 MOVE A,LSPRMP# ;$$INITIALIZE TO TOP LEVEL PROMPT
25000 ;$$CAN BE CHANGED BY INITPROMPT
25100 PUSHJ P,PROMPT ;$$
25200
25300 SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
25400 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
25500 PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
25600 HRROI 0,CNIL2(S) ;initialize nil
25700 MOVEM 0,STNIL# ;$$SAVE FOR REG CHECK AT START TIME
25800 IFN HASH,<
25900 SKIPE HASHFG#
26000 JRST REHASH ;rehash if necessary>
26100 SKIPN F
26200 PUSHJ P,AGC ;garbage collect only if necessary
26300 SKIPN BSFLG# ;initial bootstrap for macros
26400 JRST BOOTS
26500 SKIPE A,INITF
26600 CALLF (A) ;evaluate initialization function
26700 PUSHJ P,TTYRET ;return all i/o to tty
26800 PUSHJ P,TERPRI
26900 SKIPE GOBF# ;garbaged oblist flag
27000 STRTIP [SIXBIT /GARBAGED OBLIST←!/]
27100 SETZM GOBF
27200 SKIPE BPSFLG#
27300 JRST BINER2 ;binary program space exceeded by loader
27400 LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
27500 ;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
27600 PUSHJ P,READ ;this is the top level of lisp
27700 PUSHJ P,EVAL
27800 PUSHJ P,PRINT
27900 PUSHJ P,TERPRI
28000 JRST LISP1
28100 PAGE
28200 INITFN: EXCH A,INITF#
28300 POPJ P,
28400
28500 ;return from lisp error
28600 LSPRET: PUSHJ P,TERPRI
28700 MOVE B,SC2 ;RETURN FROM BELL
28800 PUSHJ P,UBD ;unbind specpdl
28900 JRST LSPRT1
29000
29100 .RSET: EXCH A,RSTSW#
29200 POPJ P,
29300
29400 ;BOOTSTRAPPER FOR USER'S INIT FILE
29500 BOOTS: SETOM BSFLG
29600 MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
29700 MOVEM A,BOOPT#
29800 MOVEI A,BSTYI
29900 PUSHJ P,READP1
30000 PUSHJ P,EVAL
30100 JUMPE A,BOOTOT
30200 MOVEI A,BSTYI
30300 PUSHJ P,READP1
30400 PUSH P,A
30500 MOVE A,(P)
30600 PUSHJ P,ERRSET
30700 CAIE A,$EOF$(S)
30800 JRST .-3
30900 BOOTOT: PUSHJ P,EXCISE
31000 JRST ERR
31100
31200 BSTYI: ILDB A,BOOPT
31300 POPJ P,
31400 PAGE
31500 SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
31600 ;arithmetic processor interupts
31700 ;mem. protect. violation, nonex. mem. or pdl overflow
31800
31900 APRINT: MOVE R,JOBCNI ;get interupt bits
32000 TRNE R,MPV+NXM ;what kind
32100 ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
32200 JUMPN NIL,MES21 ;a pdl overflow
32300 STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
32400 JRST START
32500
32600 MES21: SETZM JOBUUO
32700 SKIPL P
32800 STRTIP [SIXBIT /←REG !/]
32900 SKIPL SP
33000 STRTIP [SIXBIT /←SPEC !/]
33100 SKIPE JOBUUO
33200 SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
33300 TRNE R,PDOV
33400 SKIPE JOBUUO
33500 HALT ;lisp should not be here
33600 BINER2: SETZM BPSFLG
33700 ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
33800
33900 ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
34000 CAIE R,F ;does it contain f
34100 ERR3 @JOBTPC ;no! error
34200 PUSHJ P,AGC ;yes! garbage collect
34300 JRST @JOBTPC ;and continue
34400 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
34500
34600 UUOMIN==1
34700 UUOMAX==4
34800
34900 REMOTE<UUOH: X ;jsr location
35000 JRST UUOH2>
35100 UUOH2: MOVEM T,TSV#
35200 MOVEM TT,TTSV#
35300 LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
35400 CAIGE T,34 ;is it a function call
35500 JRST ERROR ;or a LISP error
35600 HLRE R,@JOBUUO
35700 AOJN R,UUOS
35800 LDB T,[POINT 4,JOBUUO,ACFLD]
35900 CAILE T,15
36000 MOVEI R,-15(T)
36100 HRRZ T,@JOBUUO
36200 UUOH1: HLRZ TT,(T)
36300 HRRZ T,(T)
36400 CAIN TT,SUBR(S)
36500 JRST @UUST(R)
36600 CAIN TT,FSUBR(S)
36700 JRST @UUFST(R)
36800 CAIN TT,LSUBR(S)
36900 JRST @UULT(R)
37000 CAIN TT,EXPR(S)
37100 JRST @UUET(R)
37200 CAIN TT,FEXPR(S)
37300 JRST @UUFET(R)
37400 HRRZ T,(T)
37500 JUMPN T,UUOH1
37600 PUSH P,A
37700 PUSH P,B
37800 HRRZ A,JOBUUO
37900 MOVEI B,VALUE(S)
38000 PUSHJ P,GET
38100 JUMPN A,[ HRRZ TT,(A)
38200 POP P,B
38300 POP P,A
38400 JRST UUOEX1]
38500 HRRZ A,JOBUUO
38600 PUSHJ P,EPRINT
38700 ERR1 [SIXBIT /UNDEFINED UUO!/]
38800 PAGE
38900 SKIPA T,TT
39000 UUOSBR: HLRZ T,(T)
39100 MOVE TT,JOBUUO
39200 HRLI T,(PUSHJ P,)
39300 TLNE TT,1000 ;1000 means no push
39400 TLCA T,34600 ;<PUSHJ P,>xor<JRST>
39500 PUSH P,UUOH
39600 SOS UUOH
39700 HRRZ D,UUOH
39800 CAIG D,SHRST
39900 JRST .+3
40000 SKIPE WRTSTS
40100 JRST .+3
40200 REMOTE<UUOCL: TLNN TT,2000> ;2000 means no clobber
40300 XCT UUOCL
40400 MOVEM T,@UUOH
40500 MOVE TT,TTSV
40600 EXCH T,TSV
40700 JRST @TSV
40800
40900 UUOS: HRRZ TT,JOBUUO
41000 CAILE TT,@GCPP1
41100 CAIL TT,@GCP1
41200 JRST UUOSBR-1
41300 JRST .+2
41400 UUOEXP: HLRZ TT,(T)
41500 UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
41600 TRZN T,20
41700 PUSH P,UUOH
41800 PUSH P,TT
41900 JUMPE T,IAPPLY
42000 CAIN T,17
42100 MOVEI T,1
42200 MOVNS T
42300 HRLZ TT,T
42400 PUSH P,A(TT)
42500 AOBJN TT,.-1
42600 JRST IAPPLY
42700 PAGE
42800 ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
42900 MOVNS T
43000 HRLZ R,T
43100 ARGP1: JUMPE R,(TT)
43200 PUSH P,A(R)
43300 AOBJN R,.-1
43400 JRST (TT)
43500
43600 QTIFY: PUSHJ P,NCONS
43700 MOVEI B,CQUOTE(S)
43800 JRST XCONS
43900
44000 QTLFY: MOVEI A,0
44100 QTLFY1: JUMPE T,(TT)
44200 EXCH A,(P)
44300 PUSHJ P,QTIFY
44400 POP P,B
44500 PUSHJ P,CONS
44600 AOJA T,QTLFY1
44700
44800 PDLARG: JRST .+NACS+2(T)
44900 POP P,A+5
45000 POP P,A+4
45100 POP P,A+3
45200 POP P,A+2
45300 POP P,A+1
45400 POP P,A
45500 JRST (TT)
45600
45700 NOUUO: MOVSI B,(TLNN TT,)
45800 SKIPE A
45900 MOVSI B,(TLNA)
46000 HLLM B,UUOCL
46100 EXCH A,NOUUOF#
46200 POPJ P,
46300 PAGE
46400 ;r=0 => compiler calling a -
46500 ;r=1 => compiler calling a lsubr
46600 ;r=2 => compiler calling f type
46700 UUST: UUOSBR
46800 UUOS1 ;calling l its a subr
46900 UUOS2 ;calling f
47000
47100
47200 UUFST: UUOS9 ;calling - its a f
47300 UUOS10 ;calling l
47400 UUOSBR
47500
47600 UULT: UUOS7 ;calling - its a l
47700 UUOSBR
47800 UUOS8
47900
48000 UUET: UUOEXP
48100 UUOS5 ;calling l its an expr
48200 UUOS6 ;calling f its an expr
48300
48400 UUFET: UUOS3 ;calling - its a fexpr
48500 UUOS4 ;calling l
48600 UUOEXP
48700
48800 UUOS1: HLRZ R,(T)
48900 MOVE T,TSV
49000 JSP TT,PDLARG
49100 JRST (R)
49200
49300 UUOS3: PUSH P,(T)
49400 JSP TT,ARGPDL
49500 UUOS4A: JSP TT,QTLFY
49600 MOVEI TT,1
49700 DPB TT,[POINT 4,JOBUUO,ACFLD]
49800 UUOS6A: POP P,TT
49900 HLRZS TT
50000 JRST UUOEX1
50100
50200 UUOS4: PUSH P,(T)
50300 MOVE T,TSV
50400 JRST UUOS4A
50500 PAGE
50600 UUOS5: HLRZ R,(T)
50700 MOVE T,TSV
50800 JSP TT,PDLARG
50900 MOVE TT,R
51000 JRST UUOEX1
51100
51200 UUOS6: PUSH P,(T)
51300 PUSH P,UUOH
51400 PUSH P,JOBUUO
51500 JSP TT,ILIST
51600 JSP TT,PDLARG
51700 POP P,JOBUUO
51800 POP P,UUOH
51900 JRST UUOS6A
52000 UUOS8: SKIPA TT,CILIST
52100 UUOS7: MOVEI TT,ARGPDL
52200 HRRM TT,UUOS7A
52300 MOVE TT,JOBUUO
52400 TLNN TT,1000
52500 PUSH P,UUOH
52600 HLRZ TT,(T)
52700 JRST @UUOS7A ;OR ILIST
52800 REMOTE<UUOS7A: ARGPDL>
52900
53000 UUOS9: PUSH P,T
53100 JSP TT,ARGPDL
53200 UUS10A: JSP TT,QTLFY
53300 MOVSI T,2000
53400 IORM T,JOBUUO
53500 POP P,T
53600 JRST UUOSBR
53700
53800 UUOS10: PUSH P,T
53900 MOVE T,TSV
54000 JRST UUS10A
54100
54200 SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
54300 ;subroutine to print sixbit error message
54400 ERRSUB: MOVSI A,(POINT 6,0)
54500 HRR A,JOBUUO
54600 MOVEM A,ERRPTR#
54700 ERRORB: ILDB A,ERRPTR
54800 CAIN A,01 ;conversion from sixbit
54900 POPJ P,
55000 CAIN A,77
55100 JRST [ PUSHJ P,TERPRI
55200 JRST ERRORB]
55300 ADDI A,40
55400 PUSHJ P,TYO
55500 JRST ERRORB
55600
55700 ;subroutine to return output to previously selected device
55800 OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
55900 SOSL PRVCNT ;when prvcnt goes negative, then reselect
56000 POPJ P,
56100 PUSH P,PRVSEL# ;previously selected output
56200 POP P,TYOD
56300 POPJ P,
56400
56500 ;subroutine to force error messages out on tty
56600 ERRIO: MOVE B,ERRSW
56700 CAIE B,INUM0 ;inum0 specifies to print message on selected device
56800 AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
56900 POPJ P,
57000 TALK ;undo control o
57100 MOVE B,[JRST TTYO]
57200 EXCH B,TYOD
57300 MOVEM B,PRVSEL
57400 POPJ P,
57500
57600 ;ERRTN: 0 ;0 => top level *
57700 ;- => pdl to reset to - stored by errorset
57800 ;+ => string tyo pout rtn flag
57900 REMOTE<ERRSW: -1> ;0 means no prnt on error *
58000 PAGE
58100 ;subroutine to search oblist for closest function to address in r
58200 ERSUB3:
58300 MOVEI A,QST(S)
58400 HRROI NIL,CNIL2(S)
58500 HRLZ B,INT1
58600 MOVNS B
58700 SETZB AR2A,GOBF
58800 PUSH P,JOBAPR
58900 MOVEI C,[ SETOM GOBF
59000 JRST ERRO2G]
59100 HRRM C,JOBAPR
59200 HLRZ C,@RHX5
59300 ERRO2B: JUMPE C,[ AOBJN B,.-1
59400 POP P,JOBAPR ;oblist done, restore
59500 JRST PRINC] ;print closest match
59600 HLRZ TT,(C)
59700 ERRO2C: HRRZ TT,(TT)
59800 JUMPE TT,ERRO2G
59900 HLRZ AR1,(TT)
60000 CAIN AR1,LSUBR(S)
60100 JRST ERRO2H
60200 CAIE AR1,SUBR(S)
60300 CAIN AR1,FSUBR(S)
60400 JRST ERRO2H
60500 HRRZ TT,(TT)
60600 JRST ERRO2C
60700
60800 ERRO2H: HRRZ TT,(TT)
60900 HLRZ TT,(TT)
61000 CAMLE TT,AR2A ;le to prefer car to quote
61100 CAMLE TT,R
61200 JRST ERRO2G
61300 MOVE AR2A,TT
61400 HLRZ A,(C)
61500 ERRO2G: HRRZ C,(C)
61600 JRST ERRO2B
61700 PAGE
61800 ;dispatcher for error message uuos
61900 ERROR: MOVEI A,APRFLG
62000 CALLI A,APRINI ;enable interupts
62100 LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
62200 CAIL A,UUOMIN ;what
62300 CAILE A,UUOMAX ;is it?
62400 JRST ILLUUO ;an illegal opcode
62500 JRST @ERRTAB-UUOMIN(A) ;or LISP error
62600 ERRTAB: ERROR1 ;1 ;ordinary LISP error
62700 ERRORG ;2 ;space overflow error
62800 ERROR2 ;3 ;ill. mem. ref.
62900 STRTYP ;4 ;print error message and continue
63000 ERRORG: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
63100 SKIPN P
63200 MOVE P,C2 ;else to top level
63300 SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
63400
63500 ERROR1: SKIPN ERRSW
63600 JRST ERREND ;dont print message, call (err nil)
63700 PUSHJ P,ERRIO ;print message on tty
63800 PUSHJ P,TERPRI
63900 PUSHJ P,ERRSUB ;print the message
64000 JRST ERRBK ;go the backtrace
64100
64200 STRTYP: PUSHJ P,ERRIO
64300 PUSHJ P,ERRSUB ;print message and continue
64400 PUSHJ P,OUTRET
64500 JRST @UUOH
64600
64700 ;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
64800 .ERROR: JUMPE A,ERREND
64900 SKIPN ERRSW
65000 JRST ERREND
65100 PUSHJ P,ERRIO
65200 PUSHJ P,TERPRI
65300 PUSHJ P,PRINC
65400 JRST ERREND
65500 PAGE
65600 ERROR2: HRRZ A,JOBUUO
65700 MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
65800 JRST ERSUB2
65900
66000 ILLUUO: HRRZ A,UUOH
66100 MOVEI B,[SIXBIT / ILL UUO FROM !/]
66200 ERSUB2: SKIPN ERRSW
66300 JRST ERREND ;dont print message
66400 PUSH P,A
66500 PUSH P,B
66600 PUSHJ P,ERRIO
66700 PUSHJ P,TERPRI
66800 PUSHJ P,PRINL2 ;print number
66900 POP P,A
67000 STRTIP (A) ;print message
67100 POP P,R
67200 PUSHJ P,ERSUB3 ;print nearest oblist match
67300 ERRBK:
67400 IFN ALVINE,<
67500 SKIPE BACTRF
67600 PUSHJ P,BKTRC ;print backtrace
67700 >
67800 PUSHJ P,OUTRET ;return to previous device
67900 ERREND: PUSHJ P,%CLRBFI ;CLEAR INPUT BUFFER
68000 SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
68100 JRST .+3
68200 SETZM UUO2 ;$$RESET TO ZERO
68300 JRST RERX ;$$BOUNCE BACK TO ERRORX
68400 SKIPN RSTSW ;$$NEW *RSET FEATURE
68500 JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
68600 SKIPN ERRSW ;$$NO ERRORX IF NO MESSAGE
68700 JRST ERR ;$$
68800 MOVEI A,ERRORX(S) ;$$ELSE SET TO CALL ERROR HANDLER
68900 MOVEI B,NIL ;$$CREATE FORM (ERRORX)
69000 CEV: PUSHJ P,CONS ;$$
69100 JRST EVAL ;$$AND EVALUATE IT
69200
69300
69400 ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
69500 CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
69600 JRST RERX
69700 ERR2: SKIPN ERRTN
69800 JRST LSPRET ;not in an errset, or bad error -- go to top level
69900 MOVE P,ERRTN
70000 ERR1: POP P,B
70100 PUSHJ P,UBD ;unbind to previous errset
70200 POP P,ERRSW
70300 POP P,ERRTN
70400 SKIPN INHERR#
70500 JRST ERRP4 ;and proceed
70600
70700 RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
70800 MOVE B,ERRSW
70900 CAIE B,ERRORX(S)
71000 SETOM INHERR
71100 JRST ERR2
71200
71300 ERRSET: PUSH P,PA3
71400 PUSH P,PA4
71500 PUSH P,ERRTN
71600 PUSH P,ERRSW
71700 PUSH P,SP
71800 MOVEM P,ERRTN
71900 HRRZ C,(A)
72000 HLRZ C,(C)
72100 MOVEM C,ERRSW
72200 HLRZ A,(A)
72300 PUSHJ P,EVAL
72400 PUSHJ P,NCONS
72500 SETZM INHERR ;CLEAR RERX FLAG
72600 JRST ERR1
72700
72800 SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
72900 JRST FALSE ;MIGHT BE EXTENDED LATER
73000 PAGE
73100 ;error messages
73200
73300
73400
73500
73600 RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
73700 PUSHJ P,EPRINT ;$$
73800 ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
73900 BNDERR: PUSHJ P,EPRINT ;$$ATTEMPT TO REBIND NIL OR T
74000 ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
74100
74200 RPAERR: PUSHJ P,EPRINT ;$$PRINT OUT OFFENDING ITEM
74300 ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
74400
74500 RPDERR: PUSHJ P,EPRINT ;$$
74600 ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
74700
74800 DOTERR: SETZM OLDCH
74900 ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
75000 UNDFUN: HLRZ A,(AR1)
75100 PUSHJ P,EPRINT
75200 ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
75300 UNBVAR: PUSHJ P,EPRINT
75400 ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
75500 NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
75600 NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
75700 NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
75800 TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
75900 TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
76000 UNDTAC: HRRZ A,(C)
76100 UNDTAG: PUSHJ P,EPRINT
76200 ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
76300 SETERR: PUSHJ P,EPRINT ;$$BAD SET OR SETQ
76400 ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
76500 EG1: PUSHJ P,EPRINT
76600 ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
76700 EG2: PUSHJ P,EPRINT
76800 ERR1 [SIXBIT /GO WITH NO PROG!/]
76900 EG3: ERR1 [SIXBIT /RETURN WITH NO PROG!/]
77000 PAGE
77100 IFN ALVINE,<
77200
77300 ;backtrace subroutine
77400 BKTRC: MOVEI D,-1(P)
77500 MOVN A,BACTRF
77600 ADDI A,INUM0
77700 JUMPL A,[ ADD A,P ;backtrace specific number
77800 JRST .+3]
77900 SKIPN A,ERRTN ;backtrace to previous errset
78000 MOVE A,C2 ;or top level
78100 HRRZM A,BAKLEV#
78200 STRTIP [SIXBIT /←BACKTRACE←!/]
78300 BKTR2: CAMG D,BAKLEV
78400 JRST FALSE ;done
78500 HRRZ A,(D) ;get pdl element
78600 CAIGE A,FS(S)
78700 JUMPN A,.+2 ;this is (hopefully) a true program address
78800 SOJA D,BKTR2 ;not a program address, continue
78900 CAIN A,ILIST3
79000 JRST BKTR1A ;argument evaluation
79100 BKTR1B: CAIN A,CPOPJ
79200 JRST [ HLRZ A,(D) ;calling a function
79300 PUSHJ P,PRINC
79400 XCT "-",CTY
79500 STRTIP [SIXBIT /ENTER !/]
79600 SOJA D,BKTR2]
79700 HLRZ B,-1(A)
79800 CAILE B,(JCALLF 17,@(17))
79900 CAIN B,(PUSHJ P,) ;tests for various types of calls
80000 CAIGE B,(FCALL)
80100 SOJA D,BKTR2 ;not a proper function call
80200 PUSH P,-1(A) ;save object of function call
80300 MOVEI R,-1(A) ;location of function call
80400 PUSHJ P,ERSUB3 ;print closest oblist match
80500 MOVEI A,"-"
80600 PUSHJ P,TYO
80700 POP P,R
80800 TLNE R,17
80900 HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
81000 HRRZS R
81100 HLRO B,(R)
81200 AOSN B
81300 JRST [ HRRZ A,R ;was calling an atomic function
81400 PUSHJ P,PRINC ;print its name
81500 JRST .+2]
81600 PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
81700 MOVEI A," "
81800 PUSHJ P,TYO
81900 BKTR1: SOJA D,BKTR2 ;continue
82000
82100 BKTR1A: HRRZ B,-1(D)
82200 CAIE B,EXP2
82300 CAIN B,ESB1
82400 JRST .+2
82500 JRST BKTR1B ;hum, not really evaluating arguments
82600 HLRE B,-1(D)
82700 ADD B,D
82800 HLRZ A,-3(B)
82900 JUMPE A,BKTR1
83000 PUSHJ P,PRINC
83100 XCT "-",CTY
83200 STRTIP [SIXBIT /EVALARGS !/]
83300 JRST BKTR1
83400 >
83500
83600 BAKGAG: EXCH A,BACTRF#
83700 POPJ P,
00100 SUBTTL TYI AND TYO --- PAGE 6
00200 ;input
00300 ITYI: PUSHJ P,TYI
00400 FIXI: ADDI A,INUM0
00500 POPJ P,
00600
00700 TYI: MOVEI AR1,1
00800 PUSHJ P,TYIA
00900 JUMPE A,.-1
01000 CAME A,IGSTRT ;start of comment or ignored cr-lf
01100 POPJ P,
01200 PUSHJ P,COMMENT
01300 JRST TYI+1
01400
01500 TYIA: SKIPE A,OLDCH
01600 JRST TYI1
01700 TYID: XCT TYI2
01800 REMOTE<TYI2: JRST TTYI> ;sosg x for other device input
01900 ;other device input
02000 JRST TYI2X
02100 TYI3B: ILDB A,@TYI3# ;pointer
02200 XCT TYI3A
02300 REMOTE<TYI3A: TDNN AR1,@X> ;pointer
02400 POPJ P,
02500 IFN STPGAP,<
02600 MOVE A,@TYI3A
02700 CAMN A,[<ASCII / />+1] ;page mark for stopgap
02800 AOSA PGNUM ;increment page number
02900 MOVEM A,LINUM
03000 >
03100 MOVNI A,5
03200 ADDM A,@TYI2 ;adjust character count for line number
03300 AOS @TYI3 ;increment byte pointer over line number and tab
03400 JRST TYID
03500
03600 REMOTE< TYI2X: INPUT X,
03700 TYI2Y: STATZ X,740000
03800 ERR1 AIN.8 ;input error
03900 TYI2Z: STATO X,20000
04000 JRST TYI3B ;continue with file
04100 JRST TYI2Q ;END OF FILE>
04200 TYI2Q: PUSH P,T
04300 PUSH P,C
04400 PUSH P,R
04500 PUSH P,AR1
04600 MOVE A,INCH
04700 HRRZ C,CHTAB(A) ;get location of data for this channel
04800 HLRZ T,CHTAB(A) ;inlst -- remaining files to input
04900 JUMPE T,TYI2E ;none left -- stop
05000 PUSHJ P,SETIN ;start next input
05100 POP P,AR1
05200 POP P,R
05300 POP P,C
05400 POP P,T
05500 JRST TYI
05600
05700 TYI2E: PUSHJ P,INCNT ;(inc nil t)
05800 TALK ;turn off control o
05900 MOVEI A,$EOF$(S) ;we are done
06000 JRST ERR
06100
06200 IFN STPGAP,<
06300 PGLINE: MOVE C,[POINT 7,LINUM]
06400 PUSHJ P,NUM10 ;convert ascii line number to a integer
06500 ADDI A,INUM0
06600 MOVE B,PGNUM
06700 ADDI B,INUM0+1
06800 JRST XCONS>
06900
07000 REMOTE< OLDCH: 0
07100 IFN STPGAP,<
07200 PGNUM: 0
07300 LINUM: 0
07400 0>> ;zero to terminate num10
07500
07600 ;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
07700 ; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
07800 ; - TAKES NO ARGUMENTS
07900 ECHO: SETO A,
08000 TTYUUO 6,A ;GET STATUS BITS
08100 TLC A,4 ;COMPLEMENT THE ECHO BIT
08200 TTYUUO 7,A ;RESTORE THE BITS
08300 TLNE A,4 ;TEST TO GET FINAL VALUE
08400 JRST FALSE
08500 JRST TRUE
08600
08700 ;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
08800 ; - 0 ARGS AND RETURNS NIL
08900 %CLRBFI:CLRBFI ;CLEAR BUFFER
09000 SETZM SMAC ;CLEAR SPLICE LIST
09100 SETZM OLDCH ;CLEAR LAST CHAR.
09200 JRST FALSE
09300 PAGE
09400 ;teletype input
09500
09600 TTYI: SKIPE DDTIFG
09700 JRST TTYID
09800 INCHSL A ;single char if line has been typed
09900 JRST [TALK ;turn off control o, this
10000 ;can be omitted when ttyser is fixed
10100 OUTCHR PROMCH# ;$$OUTPUT PROMPT CHARACTER
10200 INCHWL A ;wait for a line
10300 JRST .+1]
10400 TTYXIT: CAIE A,BELL
10500 POPJ P,
10600 IFN ALVINE,<
10700 SKIPE PSAV1# ;bell from alvine?
10800 JRST [ MOVE P,PSAV1 ;yes, return to alvine
10900 JRST @ED1];$$DOUBLY IMPROVED MAGIC>
11000 MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
11100 JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
11200
11300 TTYID: TALK ;turn off control o, remove this when ttyser works
11400 INCHRW A ;single character input ddt submode style
11500 CAIE A,RUBOUT
11600 JRST TTYXIT
11700 OUTCHR ["\"] ;echo backslash
11800 SKIPE PSAV
11900 JRST RDRUB ;rubout in read resets to top level of read
12000 MOVEI A,RUBOUT
12100 POPJ P,
12200
12300
12400 PROMPT: SKIPN A
12500 SKIPA A,PROMCH
12600 MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
12700 EXCH A,PROMCH# ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
12800 MOVEI A,INUM0(A) ;$$CHANGE TO INUM
12900 POPJ P, ;$$
13000
13100
13200 INTPRP: SKIPN A
13300 SKIPA A,LSPRMP
13400 EXCH A,LSPRMP# ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
13500 POPJ P, ;$$
13600
13700 READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
13800 JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
13900 JRST TRUE
14000
14100 UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
14200 MOVEM B,OLDCH
14300 POPJ P, ;$$ RETURN ARG AS VALUE
14400 PAGE
14500 ;output
14600 ITYO: SUBI A,INUM0
14700 PUSHJ P,TYO
14800 JRST FIXI
14900
15000 TYO: CAIG A,CR
15100 JRST TYO3
15200 SOSGE CHCT
15300 JRST TYO1
15400 JRST TYOD
15500 REMOTE<TYOD: JRST TTYO+X ;sosg x for other device
15600 ;other device output
15700 JRST TYO2X
15800 TYO5: IDPB A,X
15900 POPJ P,
16000
16100 TYO2X: OUT X,
16200 JRST TYO5
16300 ERR1 [SIXBIT /OUTPUT ERROR!/]>
16400
16500 TYO1: PUSH P,A ;linelength exceeded
16600 MOVEI A,IGCRLF ;inored cr-lf
16700 PUSHJ P,TYOD
16800 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
16900 POP P,A
17000 SOSA CHCT
17100 TYO4: POP P,B
17200 JRST TYOD
17300
17400 TYO3: CAIGE A,TAB
17500 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
17600 PUSH P,B
17700 MOVE B,LINL
17800 CAIN A,TAB
17900 JRST [ SUB B,CHCT
18000 IORI B,7 ;simulate tab effect on chct
18100 SUB B,LINL
18200 SETCAM B,CHCT
18300 JRST TYO4]
18400 CAIN A,CR
18500 MOVEM B,CHCT ;reset chct after a cr
18600 JRST TYO4
18700
18800 LINELENGTH:
18900 JUMPE A,LINEL1
19000 SUBI A,INUM0
19100 HRRM A,LINL
19200 HRRM A,CHCT
19300 LINEL1: HRRZ A,LINL
19400 JRST FIXI
19500
19600 CHRCT: MOVE A,CHCT
19700 JRST FIXI
19800
19900 REMOTE<
20000 LINL: TTYLL
20100 CHCT: TTYLL>
20200
20300 ;teletype output
20400 TTYO: OUTCHR A ;output single character in a
20500 POPJ P,
20600 PAGE
20700 REMOTE<DDTIFG: TRUTH>
20800 DDTIN: EXCH A,DDTIFG
20900 POPJ P,
21000
21100
21200 TTYRET: PUSHJ P,OUTCNT
21300 JRST INCNT
21400 ;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
21500 TTYCLR: SKPINC
21600 CAI
21700 POPJ P,
21800
21900 REMOTE<
22000 TTOCH: 0
22100 IFN STPGAP,<
22200 0 ;tty page number always zero
22300 0 ;tty line number -- always zero
22400 >
22500 TTOLL: TTYLL
22600 TTOHP: TTYLL>
22700 PAGE
22800 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
22900 ;convert ascii to sixbit for device initialization routines
23000 SIXMAK: SETZM SIXMK2#
23100 MOVE AR1,[POINT 6,SIXMK2]
23200 HRROI R,SIXMK1
23300 PUSHJ P,PRINTA ;use print to unpack ascii characters
23400 MOVE A,SIXMK2
23500 POPJ P,
23600
23700 SIXMK1: ADDI A,40
23800 TLNN AR1,770000
23900 POPJ P, ;last character position -- ignore remaining chars
24000 CAIN A,"."+40
24100 MOVEI A,0 ;ignore dots at end of numbers for decimal base
24200 CAIN A,":"+40
24300 HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
24400 IDPB A,AR1
24500 POPJ P,
24600
24700 ;subroutine to process next item in file name list
24800 INXTIO: JUMPE T,NXTIO
24900 HRRZ T,(T)
25000 NXTIO: HLRZ A,(T)
25100 PUSHJ P,ATOM
25200 JUMPE A,CPOPJ ;non-atomic
25300 HLRZ A,(T)
25400 JRST SIXMAK ;make sixbit if atomic
25500
25600 ;right normalize sixbit
25700 LSH A,-6
25800 SIXRT: TRNN A,77
25900 JRST .-2
26000 POPJ P,
26100 PAGE
26200 IOSUB: PUSHJ P,NXTIO
26300 MOVEM T,DEVDAT#
26400 LDB B,[POINT 6,A,35]
26500 JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
26600 CAIE B,":"-40
26700 JRST IOFIL ;not a device name -- must be file name
26800 TRZ A,77 ;clear out the :
26900 SETZM PPN
27000 IODEV2: MOVEM A,DEV
27100 PUSHJ P,INXTIO
27200 IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
27300 PUSHJ P,PPNEXT
27400 JUMPN A,IOEXT ;(fil.ext)
27500 HLRZ A,(T)
27600 HLRZ A,(A) ;caar is project number
27700 IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROJECT NUMBER IS AN INUM>
27710 IFN STANSW,< PUSHJ P,SIXMAK
27720 PUSHJ P,SIXRT>
27800 HRLM A,PPN ;project number
27900 HLRZ A,(T)
28000 PUSHJ P,CADR ;cadar is programmer number
28100 IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROGRAMMER NUMBER IS AN INUM>
28110 IFN STANSW,< PUSHJ P,SIXMAK
28120 PUSHJ P,SIXRT>
28200 HRRM A,PPN ;programmer number
28300 HRLZI A,(SIXBIT /DSK/) ;disk is assumed
28400 JRST IODEV2
28500
28600 IOFIL: SKIPN DEV
28700 JRST AIN.1 ;no device named
28800 JUMPN A,IOFIL2 ;was it an atom
28900 JUMPE T,CPOPJ ;no, was it nil (end)
29000 PUSHJ P,PPNEXT
29100 JUMPE A,CPOPJ ;see a ppn, no file named
29200 IOEXT: HLRZ A,(T) ;(file.ext)
29300 HRRZ A,(A) ;get cdr == extension
29400 PUSHJ P,SIXMAK
29500 HLLM A,EXT
29600 HLRZ A,(T)
29700 HLRZ A,(A) ;get car = file name
29800 PUSHJ P,SIXMAK
29900 FIL: PUSH P,A
30000 PUSHJ P,INXTIO
30100 JRST POPAJ
30200
30300 IOFIL2: CAIN B,":"-40
30400 POPJ P, ;saw a :,not file name
30500 SETZM EXT ;file name -- clear extension
30600 JRST FIL
30700
30800 PPNEXT: JUMPE T,CPOPJ ;end of file name list
30900 HLRZ A,(T)
31000 HRRZ A,(A) ;cdar
31100 JRST ATOM ;ppn iff (not(atom(cdar l)))
31200
31300 CHNSUB: MOVE T,A
31400 HLRZ A,(T)
31500 PUSHJ P,ATOM
31600 JUMPE A,TRUE ;non-atomic head of list -- no channel named
31700 HLRZ A,(T)
31800 PUSHJ P,SIXMAK
31900 ANDI A,77
32000 CAIN A,":"-40
32100 JRST TRUE ;device name, assume channel name t
32200 HLRZ A,(T) ;channel name -- return it
32300 HRRZ T,(T)
32400 POPJ P,
32500
32600 REMOTE<
32700 CHTAB=.-FSTCH
32800 BLOCK NIOCH>
32900
33000 ;channel data
33100 CHNAM==0 ;name of channel
33200 CHDEV==1 ;name of device
33300 CHPPN==2 ;ppn for input channel
33400 CHOCH==3 ;oldch for input channels
33500 IFN STPGAP,<
33600 CHPAGE==4 ;page number for input
33700 CHLINE==5 ;line number for input
33800 CHDAT==6 ;device data
33900 POINTR==7 ;byte pointer for device buffer
34000 COUNT==10 ;character count for device buffer
34100 >
34200 IFE STPGAP,<
34300 CHDAT==4
34400 POINTR==5
34500 COUNT==6
34600 >
34700 CHLL==2 ;linelength for output channel
34800 CHHP==3 ;hposit for output channels
34900 PAGE
35000 ;search for channel name in chtab
35100 TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
35200 MOVE C,CHTAB(A)
35300 CAME B,CHNAM(C)
35400 AOBJN A,.-2
35500 CAMN B,CHNAM(C)
35600 POPJ P, ;found it!!!
35700 JRST FALSE ;lost
35800
35900 ;search for channel name in chtab, and if not there find a free channel, and
36000 ;if no free channel, allocate a new buffer and channel
36100 TABSRC: MOVE B,A
36200 PUSHJ P,TABSR1
36300 JUMPN A,DEVCLR ;found the channel
36400 PUSH P,B
36500 MOVE B,0
36600 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
36700 JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
36800 POP P,B
36900 JUMPN C,DEVCLR ;found free channel which had buffer space previously
37000 PUSH P,A ;must allocate new buffer
37100 MOVEI A,BLKSIZ
37200 SETZ D, ;SPECIAL RELOCATION - SEE LOAD
37300 PUSHJ P,MORCOR ;expand core for buffer if necessary
37400 MOVE C,A
37500 POP P,A
37600 HRRM C,CHTAB(A)
37700 DEVCLR: HRRZ C,CHTAB(A)
37800 HRRZM B,CHNAM(C) ;store name
37900 HRRZM A,CHANNEL#
38000 POPJ P,
38100
38200 ;subroutine to reset all i/o channels -- used by excise and realloc
38300 IOBRST: HRRZ A,JOBREL
38400 HRLM A,JOBSA
38500 MOVEM A,CORUSE#
38600 MOVEM A,JOBSYM
38700 SETZM CHTAB+FSTCH
38800 MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
38900 BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
39000 JRST (R)
39100 PAGE
39200 INPUT: PUSHJ P,CHNSUB ;determine channel name
39300 PUSH P,A
39400 PUSHJ P,TABSRC ;get physical channel number
39500 PUSHJ P,SETIN ;init device
39600 JRST POPAJ
39700
39800 SETIN: MOVEM A,CHANNEL
39900 MOVE A,CHDEV(C)
40000 MOVEM A,DEV
40100 MOVE A,CHPPN(C)
40200 MOVEM A,PPN
40300 PUSHJ P,IOSUB ;get device and file name
40400 MOVEM A,LOOKIN ;file name
40500 MOVE A,DEV
40600 CALLI A,DEVCHR
40700 TLNN A,INB
40800 JRST AIN.2 ;not input device
40900 TLNN A,AVLB
41000 JRST AIN.4 ;not available
41100 MOVE A,CHANNEL
41200 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
41300 DPB A,[POINT 4,INLOOK,ACFLD]
41400 DPB A,[POINT 4,ININBF,ACFLD]
41500 HRRZ B,CHTAB(A)
41600 HRLM T,CHTAB(A) ;save remaining file name list
41700 MOVEI A,CHDAT(B)
41800 MOVEM A,DEV+1 ;pointer to bufdat
41900 JRST ININIT
42000 REMOTE<
42100 ININIT: INIT X,
42200 DEV: X
42300 X
42400 JRST AIN.7 ;cant init
42500 PUSH B,DEV
42600 PUSH B,PPN
42700 INLOOK: LOOKUP X,LOOKIN
42800 JRST AIN.7 ;cant find file
42900 JRST IRET1>
43000 IRET1: PUSH B,[0] ;oldch
43100 IFN STPGAP,<
43200 PUSH B,[0] ;line number
43300 PUSH B,[0] ;page number
43400 >
43500 ADDI B,4
43600 HRRM B,JOBFF
43700 JRST ININBF
43800 REMOTE<
43900 ININBF: INBUF X,NIOB
44000 JRST TRUE
44100
44200 ENTR:
44300 LOOKIN: BLOCK 4
44400 EXT=LOOKIN+1
44500 PPN=LOOKIN+3
44600 >
44700 PAGE
44800 OUTPUT: PUSHJ P,CHNSUB ;get channel name
44900 PUSH P,A
45000 TRO A,400000 ;set bit for output
45100 PUSHJ P,TABSRC ;get physical channel nuber
45200 PUSHJ P,IOSUB ;get device and file name
45300 MOVEM A,ENTR ;file name
45400 SETZM ENTR+2 ;zero creation date
45500 MOVE A,CHANNEL
45600 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
45700 DPB A,[POINT 4,OUTENT,ACFLD]
45800 DPB A,[POINT 4,OUTOBF,ACFLD]
45900 HRRZ B,CHTAB(A)
46000 MOVEI A,CHDAT(B)
46100 HRLM A,AOUT3+1
46200 MOVE A,DEV
46300 MOVEM A,AOUT3
46400 CALLI A,DEVCHR
46500 TLNN A,OUTB
46600 JRST AOUT.2 ;not output device
46700 TLNN A,AVLB
46800 JRST AOUT.4 ;not available
46900 JRST AOUT2
47000 REMOTE<
47100 AOUT2: INIT X,
47200 AOUT3: X
47300 X
47400 JRST AOUT.4 ;cant init
47500 PUSH B,DEV
47600 OUTENT: ENTER X,ENTR
47700 JRST OUTERR ;cant enter
47800 JRST ORET1>
47900 ORET1: PUSH B,[LPTLL] ;linelength
48000 PUSH B,[LPTLL] ;chrct
48100 IFE STPGAP,< ADDI B,4>
48200 IFN STPGAP,< ADDI B,6>
48300 HRRM B,JOBFF
48400 XCT OUTOBF
48500 REMOTE<
48600 OUTOBF: OUTBUF X,NIOB
48700 >
48800 JRST POPAJ
48900
49000 OUTERR: PUSHJ P,AIOP
49100 LDB A,[POINT 3,ENTR+1,35]
49200 CAIE A,2
49300 ERR1 [SIXBIT /DIRECTORY FULL !/]
49400 ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
49500 PAGE
49600 IOSEL: MOVE C,-1(P)
49700 JUMPE C,CPOPJ ;tty
49800 JUMPE B,IOSELZ ;dont release
49900 DPB C,[POINT 4,RLS,ACFLD]
50000 XCT RLS
50100 REMOTE<
50200 RLS: RELEASE X, ;release channel
50300 >
50400 HRRZS CHTAB(C) ;release channel table entry
50500 MOVEM 0,@CHTAB(C) ;blast channel name
50600 SETZM -1(P)
50700 IOSELZ: HRRZ C,CHTAB(C)
50800 POPJ P,
50900 PAGE
51000 INCNT: MOVEI A,NIL ;(INC NIL T)
51100 MOVEI B,TRUTH(S)
51200
51300 INC: PUSH P,INCH#
51400 PUSHJ P,IOSEL
51500 JUMPN B,INC2 ;released channel
51600 SKIPN C
51700 MOVEI C,TTOCH-CHOCH ;tty deselect
51800 IFN STPGAP,<
51900 MOVEI B,CHOCH(C)
52000 HRLI B,OLDCH
52100 BLT B,CHLINE(C) ;save channel data
52200 >
52300 IFE STPGAP,<
52400 MOVE B,OLDCH
52500 MOVEM B,CHOCH(C)
52600 >
52700 JRST INC2+1
52800 INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
52900 JUMPE A,ITTYRE ;select tty
53000 MOVE B,A
53100 PUSHJ P,TABSR1 ;determine physical channel number
53200 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
53300 HRRZM A,INCH
53400 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
53500 DPB A,[POINT 4,TYI2Y,ACFLD]
53600 DPB A,[POINT 4,TYI2Z,ACFLD]
53700 HRRZ A,CHTAB(A)
53800 MOVEI T,COUNT(A)
53900 HRLI T,(SOSG)
54000 MOVEI B,POINTR(A)
54100 HRRM B,TYI3 ;set up tyi parameters
54200 HRRM B,TYI3A
54300 INC3:
54400 IFN STPGAP,<
54500 MOVSI B,CHOCH(A)
54600 HRRI B,OLDCH
54700 BLT B,LINUM ;restore channel data
54800 >
54900 IFE STPGAP,<
55000 MOVE B,CHOCH(A)
55100 MOVEM B,OLDCH
55200 >
55300 MOVEM T,TYI2
55400 IOEND: POP P,A
55500 JUMPE A,CPOPJ
55600 MOVE A,CHTAB(A) ;get channel name
55700 HRRZ A,(A)
55800 TRZ A,400000 ;clear output bit
55900 POPJ P,
56000
56100 ITTYRE: SETZM INCH
56200 MOVE T,[JRST TTYI] ;reselect tty
56300 MOVEI A,TTOCH-CHOCH
56400 JRST INC3
56500 PAGE
56600 OUTCNT: MOVEI A,0 ;(outc nil t)
56700 MOVEI B,1
56800
56900 OUTC: PUSH P,OUTCH#
57000 PUSHJ P,IOSEL
57100 JUMPN B,OUTC2 ;closed this file
57200 SKIPN C
57300 MOVEI C,TTOLL-CHLL ;tty deselect
57400 MOVE B,CHCT
57500 MOVEM B,CHHP(C) ;save channel data
57600 MOVE B,LINL
57700 MOVEM B,CHLL(C)
57800 JRST OUTC2+1
57900 OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
58000 JUMPE A,OTTYRE ;return to tty
58100 TRO A,400000 ;set output bit
58200 MOVE B,A
58300 PUSHJ P,TABSR1 ;determine physical channel number
58400 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
58500 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
58600 HRRZM A,OUTCH
58700 HRRZ A,CHTAB(A)
58800 MOVEI B,POINTR(A)
58900 HRRM B,TYO5 ;set up tyo2 parameters
59000 MOVEI T,COUNT(A)
59100 HRLI T,(SOSG)
59200 OUTC3: MOVE B,CHLL(A)
59300 MOVEM B,LINL
59400 MOVE B,CHHP(A)
59500 MOVEM B,CHCT
59600 MOVEM T,TYOD
59700 JRST IOEND
59800
59900 OTTYRE: SETZM OUTCH
60000 MOVE T,[JRST TTYO]
60100 MOVEI A,TTOLL-CHLL ;tty reselect
60200 JRST OUTC3
60300 PAGE
60400 AIN.1: PUSHJ P,AIOP
60500 ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
60600 AOUT.2:
60700 AIN.2: PUSHJ P,AIOP
60800 ERR1 [SIXBIT /ILLEGAL DEVICE!/]
60900 AOUT.4:
61000 AIN.4: PUSHJ P,AIOP
61100 ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
61200 AIN.7: PUSHJ P,AIOP
61300 ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
61400
61500 AIN.8: SIXBIT /INPUT ERROR!/
61600
61700 AIOP: MOVE A,DEVDAT
61800 JRST EPRINT
00100 SUBTTL PRINT --- PAGE 8
00200
00300 EPRINT: SKIPN ERRSW
00400 POPJ P,
00500 PUSHJ P,ERRIO
00600 PUSHJ P,PRINT
00700 JRST OUTRET
00800
00900 PRINT: MOVEI R,TYO
01000 PUSHJ P,TERPRI
01100 PUSHJ P,PRIN1
01200 XCT " ",CTY
01300 POPJ P,
01400
01500 PRINC: SKIPA R,.+1
01600 PRIN1: HRRZI R,TYO
01700 PUSH P,A
01800 PUSHJ P,PRINTA
01900 JRST POPAJ
02000
02100 PRINTA: PUSH P,A
02200 MOVEI B,PRIN3
02300 SKIPGE R
02400 MOVEI B,PRIN4
02500 HRRM B,PRIN5
02600 PUSHJ P,PATOM
02700 JUMPN A,PRINT1
02800 XCT "(",CTY
02900 PRINT3: HLRZ A,@(P)
03000 PUSHJ P,PRINTA
03100 HRRZ A,@(P)
03200 JUMPE A,PRINT2
03300 MOVEM A,(P)
03400 XCT " ",CTY
03500 PUSHJ P,PATOM
03600 JUMPE A,PRINT3
03700 XCT ".",CTY
03800 XCT " ",CTY
03900 PUSHJ P,PRIN1A
04000 PRINT2: XCT ")",CTY
04100 JRST POPAJ
04200
04300 PRINT1: PUSHJ P,PRIN1A
04400 JRST POPAJ
04500 PAGE
04600 PRIN1A: MOVE A,-1(P)
04700 CAILE A,INUMIN
04800 JRST PRINIC
04900 JUMPE A,PRIN1B
05000 CAIGE A,@GCP1
05100 CAIGE A,@GCPP1
05200 JRST PRINL
05300 PRIN1B: HRRZ A,(A)
05400 JUMPE A,PRINL
05500 HLRZ B,(A)
05600 HRRZ A,(A)
05700 CAIN B,PNAME(S)
05800 JRST PRINN
05900 CAIN B,FIXNUM(S)
06000 JRST PRINI1
06100 CAIN B,FLONUM(S)
06200 JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
06300 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
06400 JRST PRIN1B
06500
06600 PRINL2: MOVEI R,TYO
06700 JRST PRINL1
06800
06900 PRINL: XCT "#",CTY
07000 HRRZ A,-1(P)
07100 PRINL1: MOVEI C,8
07200 JRST PRINI3
07300
07400 PRINI1: SKIPA A,(A)
07500 PRINIC: SUBI A,INUM0
07600 HRRZ C,VBASE(S)
07700 SUBI C,INUM0
07800 JUMPGE A,PRINI2
07900 XCT "-",CTY
08000 MOVNS A
08100 PRINI2: MOVEI B,"."-"0"
08200 HRLM B,(P)
08300 CAIN C,TEN
08400 SKIPE %NOPOINT(S)
08500 JRST .+2
08600 PUSH P,PRINI4
08700 PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
08800 MOVEI A,1
08900 DIVI A,(C)
09000 JRST .+2]
09100 IDIVI A,0(C)
09200 HRLM B,(P)
09300 SKIPE A
09400 PUSHJ P,.-3
09500 PRINI4: JRST FP7A1
09600
09700 PRINN: HLRZ A,(A)
09800 MOVEI C,2(SP)
09900 PUSHJ P,PNAMU3
10000 PUSH C,[0]
10100 HRLI C,(POINT 7,0,35)
10200 HRRI C,2(SP)
10300 ILDB A,C
10400 JUMPE A,CPOPJ ;special case of null character
10500 CAIN A,DBLQT
10600 JRST PSTR ;string
10700 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
10800 JUMPL R,PRIN4 ;never slash
10900 JRST PRIN2(B) ;1 for no slash
11000
11100 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
11200 PRIN2: XCT "/",CTY
11300 PRIN4: PUSHJ P,(R)
11400 ILDB A,C
11500 JUMPN A,@PRIN5#
11600 POPJ P,
11700
11800 PSTR: MOVS B,(C)
11900 CAIN B,(<ASCII /"/>)
12000 JRST PRIN2X ;special case of /"
12100 PSTR3: SKIPL R ;dont print " if no slashify
12200 PSTR2: PUSHJ P,(R)
12300 ILDB A,C
12400 CAIE A,DBLQT
12500 JUMPN A,PSTR2
12600 JUMPN A,PSTR3
12700 POPJ P,
12800
12900 TERPRI: PUSH P,A
13000 MOVEI A,CR
13100 PUSHJ P,TYO
13200 MOVEI A,LF
13300 PUSHJ P,TYO
13400 JRST POPAJ
13500
13600 CTY: JSA A,TYOI
13700 REMOTE<
13800 TYOI: X
13900 JRST TYOI2>
14000 TYOI2: PUSH P,A
14100 LDB A,[POINT 6,-1(A),ACFLD]
14200 PUSHJ P,(R)
14300 POP P,A
14400 JRA A,(A)
14500
14600 PRINO: MOVE A,(A)
14700 CLEARB B,C
14800 JUMPG A,FP1
14900 JUMPE A,FP3
15000 MOVNS A
15100 XCT "-",CTY
15200 FP1: CAMGE A,FT01
15300 JRST FP4
15400 CAML A,FT8
15500 AOJA B,FP4
15600
15700 FP3: MULI A,400
15800 ASHC B,-243(A)
15900 MOVE A,B
16000 CLEARM FPTEM#
16100 PUSHJ P,FP7
16200 XCT ".",CTY
16300 MOVNI T,8
16400 ADD T,FPTEM
16500 MOVE B,C
16600
16700 FP3A: MOVE A,B
16800 MULI A,TEN
16900 PUSHJ P,FP7B
17000 SKIPE B
17100 AOJL T,FP3A
17200 POPJ P,
17300
17400 FP4: MOVNI C,6
17500 MOVEI TT,0
17600 FP4A: ADDI TT,1(TT)
17700 XCT FCP(B)
17800 TRZA TT,1
17900 FMPR A,@FCP+1(B)
18000 AOJN C,FP4A
18100 PUSH P,TT
18200 MOVNI B,-2(B)
18300 DPB B,[POINT 2,FP4C,34]
18400 PUSHJ P,FP3
18500 MOVEI A,"E"
18600 PUSHJ P,(R)
18700 MOVE A,FP4C#
18800 IORI A,51
18900 PUSHJ P,(R)
19000 POP P,A
19100 FP7: JUMPE A,FP7A1
19200 IDIVI A,TEN
19300 AOS FPTEM
19400 HRLM B,(P)
19500 JUMPE A,FP7A1
19600 PUSHJ P,FP7
19700
19800 FP7A1: HLRE A,(P)
19900 FP7B: ADDI A,"0"
20000 JRST (R)
20100
20200 353473426555 ;1e32
20300 266434157116 ;1e16
20400 FT8: 1.0E8
20500 1.0E4
20600 1.0E2
20700 1.0E1
20800 FT: 1.0E0
20900 026637304365 ;1e-32
21000 113715126246 ;1e-16
21100 146527461671 ;1e-8
21200 163643334273 ;1e-4
21300 172507534122 ;1e-2
21400 FT01: 175631463146 ;1e-1
21500 FT0:
21600 FCP: CAMLE A,FT0(C)
21700 CAMGE A,FT(C)
21800 XWD C,FT0
21900
00100 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
00200
00300 ;magic scanner table bit definitions
00400
00500 ;bit 0=0 iff slashified as nth id character
00600 ;bit 1=0 iff slashified as 1st id character
00700 ;bits 2-5 ratab index
00800 ;bits 6-8 dotab index
00900 ;bits 9-10 strtab index
01000 ;bits 11-13 idtab index
01100 ;bits 14-16 exptab index
01200 ;bits 17-19 rdtab index
01300 ;bits 20-25 ascii to radix 50 conversion
01400
01500 REMOTE<
01600 IGSTRT: IGCRLF
01700 IGEND: LF
01800
01900 RATFLD: POINT 4,CHRTAB(A),5
02000 STRFLD: POINT 2,CHRTAB(A),10
02100 IDFLD: POINT 3,CHRTAB(A),13
02200 >
02300 DOTFLD:
02400 NUMFLD: POINT 3,CHRTAB(A),8
02500 EXPFLD: POINT 3,CHRTAB(A),16
02600 RDFLD: POINT 3,CHRTAB(A),19
02700 R50FLD: POINT 6,CHRTAB(A),25
02800
02900 ;magic state flags in t
03000 EXP==1 ;exponent
03100 NEXP==2 ;negative exponent
03200 SAWDOT==4 ;saw a dot (.)
03300 MINSGN==10 ;negative number
03400
03500 IDCLS==0 ;identifier
03600 STRCLS==1 ;string
03700 NUMCLS==2 ;number
03800 DELCLS==3 ;delimiter
03900
04000 PAGE
04100 ;macros for scanner table
04200
04300 DEFINE RAD50 (X)<
04400 IFB <X>,<R50VAL=0>
04500 IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
04600 IFIDN <"X"><".">,<R50VAL=45>
04700 IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
04800
04900 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
05000 XLIST
05100 IRPC R50< RAD50 (R50)
05200 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
05300 LIST>
05400
05500 DEFINE LET (X)<
05600 TABIN (1,1,5,2,3,4,2,0,X)>
05700
05800 DEFINE DELIMIT (X,Y)<
05900 TABIN (0,0,2,2,3,2,2,Y,X)>
06000
06100 DEFINE IGNORE (X)<
06200 TABIN (0,0,3,2,3,2,2,0,X)>
06300 PAGE
06400 REMOTE<CHRTAB:
06500 TABIN (0,0,1,1,1,1,1,0,< >)
06600 ;null
06700 LET (< >)
06800 IGNORE (< >)
06900 ;tab,lf,vtab,ff,cr
07000 LET (< >)
07100 ;16 to 30
07200 TABIN (0,0,0,0,0,0,0,0,< >)
07300 ;igmrk
07400 TABIN (0,0,0,0,0,0,0,0,< >)
07500 ;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
07600 LET (< >)
07700 ;33 to 37
07800 IGNORE (< >)
07900 ;space
08000 LET (< >)
08100 ;!
08200 TABIN (0,0,9,2,2,2,2,0,< >)
08300 ;"
08400 LET (< $% >)
08500 ;#$%&'
08600 DELIMIT (< >,0)
08700 DELIMIT (< >,1)
08800 ;()
08900 LET (< >)
09000 ;*
09100 TABIN (1,1,14,2,3,4,2,0,< >)
09200 ;+
09300 IGNORE (< >)
09400 ;,
09500 TABIN (1,1,6,2,3,4,2,0,< >)
09600 ;-
09700 TABIN (0,0,7,3,3,2,2,4,<.>)
09800 TABIN (0,0,4,2,3,3,2,0,< >)
09900 ;/
10000 TABIN (1,0,8,5,3,4,3,0,<0123456789>)
10100 LET (< >)
10200 ;:;<=>?
10300 TABIN (1,0,2,2,3,4,2,5,< >)
10400 ;@
10500 LET (<ABCD>)
10600 TABIN (1,1,5,4,3,4,2,0,<E>)
10700 LET (<FGHIJKLMNOPQRSTUVWXYZ>)
10800 DELIMIT (< >,2)
10900 ;[
11000 LET (< >)
11100 ;\
11200 DELIMIT (< >,3)
11300 ;]
11400 LET (< >)
11500 ;↑←`
11600 LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
11700 ;lower case
11800 LET (< >)
11900 ;{¬
12000 DELIMIT (< >,3)
12100 ;altmode
12200 LET (< >)
12300 ;}
12400 DELIMIT (< >,6)
12500 ;rubout
12600 >
12700 PAGE
12800 READCH: PUSHJ P,TYI
12900 MOVSI AR1,AR1
13000 PUSHJ P,EXPL1
13100 JRST CAR
13200
13300 READP1: SETZM NOINFG
13400 READ0: PUSH P,TYI2
13500 PUSH P,OLDCH
13600 SETZM OLDCH#
13700 HRLI A,(JRST)
13800 MOVEM A,TYI2
13900 PUSHJ P,READ+1
14000 POP P,OLDCH
14100 POP P,TYI2
14200 POPJ P,
14300
14400 RDRUB: MOVEI A,CR
14500 PUSHJ P,TTYO
14600 MOVEI A,LF
14700 PUSHJ P,TTYO
14800 SKIPA P,PSAV#
14900 READ: SETZM NOINFG# ;0 means intern
15000 MOVEM P,PSAV
15100 PUSHJ P,READ1
15200 SETZM PSAV
15300 POPJ P,
15400
15500 READ1: PUSHJ P,RATOM
15600 POPJ P, ;atom
15700 XCT RDTAB2(B)
15800 JRST READ1 ;try again
15900
16000 RDTAB2: JRST READ2 ;0 (
16100 JFCL ;1 )
16200 JRST READ4 ;2 [
16300 JFCL ;3 ],$
16400 JFCL ;4 .
16500 JRST RDQT ;5 @
16600
16700 READ2: PUSHJ P,RATOM
16800 JRST READ2A ;atom
16900 XCT RDTAB(B)
17000
17100 READ2A: PUSH P,A
17200 PUSHJ P,READ2
17300 POP P,B
17400 JRST XCONS
17500
17600 RDTAB: PUSHJ P,READ2 ;0 (
17700 JRST FALSE ;1 )
17800 PUSHJ P,READ4 ;2 [
17900 JRST READ5 ;3 ],$
18000 JRST RDT ;4 .
18100 PUSHJ P,RDQT ;5 @
18200
18300 RDTX: PUSHJ P,RATOM
18400 POPJ P, ;atom
18500 XCT RDTAB2(B)
18600 JRST DOTERR ;dot context error
18700
18800 RDT: PUSHJ P,RDTX
18900 PUSH P,A
19000 PUSHJ P,RATOM
19100 JRST DOTERR
19200 CAIN B,1
19300 JRST POPAJ
19400 CAIE B,3
19500 JRST DOTERR
19600 MOVEM A,OLDCH
19700 JRST POPAJ
19800
19900
20000 READ4: PUSHJ P,READ2
20100 MOVE B,OLDCH
20200 CAIE B,ALTMOD
20300 TYI1: SETZM OLDCH ;kill the ]
20400 POPJ P,
20500
20600 READ5: MOVEM A,OLDCH ;save ] or $
20700 JRST FALSE ;and return nil
20800
20900
21000 RDQT: PUSHJ P,READ1
21100 JRST QTIFY
21200 PAGE
21300 ;atom parser
21400
21500 COMMENT: PUSHJ P,TYID
21600 CAME A,IGEND
21700 JRST COMMENT
21800 POPJ P,
21900
22000 RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
22100 JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
22200 SETZB T,R
22300 HRLI C,(POINT 7,0,35)
22400 HRRI C,(SP)
22500 MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
22600 MOVEI AR1,1
22700 RATOM2: PUSHJ P,TYIA
22800 LDB B,RATFLD
22900 JRST RATAB(B)
23000
23100 RATAB: PUSHJ P,COMMENT ;0 comment
23200 JRST RATOM2 ;1 null
23300 JRST RATOM3 ;2 delimit
23400 JRST RATOM2 ;3 ignore
23500 PUSHJ P,TYI ;4 /
23600 JRST RDID ;5 letter
23700 JRST RDNMIN ;6 -
23800 JRST RDOT ;7 .
23900 JRST RDNUM ;8 digit
24000 JRST RDSTR ;9 string
24100 JRST RMACRO ;10 MACRO
24200 JRST SMACRO ;11 SPLICE MACRO
24300 JRST RDNPLS ;12 +
24400
24500 ;a real dotted pair
24600 RDOT2: MOVEM A,OLDCH
24700 MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
24800 RATOM3: LDB B,RDFLD
24900 HRRI R,DELCLS ;delimiter
25000 AOS (P) ;non-atom (ie a delimiter)
25100 POPJ P,
25200
25300 ;dot handler
25400 RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
25500 PUSHJ P,TYID
25600 LDB B,DOTFLD
25700 JRST DOTAB(B)
25800
25900 DOTAB: PUSHJ P,COMMENT ;0 comment
26000 JRST RDOT+1 ;1 null
26100 JRST RDOT2 ;2 delimit
26200 JRST RDOT2 ;3 dot
26300 JRST RDOT2 ;4 e
26400 MOVEI B,0 ;5 digit
26500 IDPB B,C
26600 TLO T,SAWDOT
26700 JRST RDNUM
26800 PAGE
26900 ;string scanner
27000 STRTAB: PUSHJ P,COMMENT ;0 comment
27100 JRST RDSTR+1 ;1 null
27200 JRST STR2 ;2 delimit
27300 RDSTR: IDPB A,C ;3 string element
27400 PUSHJ P,TYID
27500 LDB B,STRFLD
27600 JRST STRTAB(B)
27700
27800 STR2: MOVEI A,DBLQT
27900 HRRI R,STRCLS ;string
28000 IDPB A,C
28100 NOINTR: PUSHJ P,IDEND ;no intern
28200 PUSHJ P,IDSUB
28300 JRST PNAMAK
28400
28500
28600 ;identifier scanner
28700 IDTAB: PUSHJ P,COMMENT ;0
28800 JRST RDID+1 ;1 null
28900 JRST MAKID ;2 delimit
29000 PUSHJ P,TYI ;3 /
29100 RDID: IDPB A,C ;4 letter or digit
29200 PUSHJ P,TYID
29300 LDB B,IDFLD
29400 JRST IDTAB(B)
29500 PAGE
29600 ;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
29700 ;
29800 LINRD: PUSHJ P,READ
29900 HRRZ B,A
30000 SKIPE SMAC ;CHECK THE SPLICE LIST
30100 JRST LRMORE
30200 SKIPN A,OLDCH
30300 LRTY: PUSHJ P,TYID ;NEED A CHARACTER
30400 MOVEM A,OLDCH ;SAVE IT
30500 LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
30600 CAIN C,7 ;SPECIAL CHECK FOR "."
30700 JRST LRTY1 ;IGNORE IT
30800 CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
30900 JRST LRMORE ;MORE ON THE LINE
31000 JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
31100 LDB C,RDFLD
31200 JRST LR1(C)
31300 LR1: JRST LPIG ;0 MORE TO FIGURE OUT
31400 JRST LRTY1 ;1 IGNORE
31500 JRST LRMORE ;2 MORE ON THE LINE
31600 SUBI A,ALTMOD ;3 CHECK ALTMOD
31700 JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
31800 JUMPN A,LRMORE ;5 MORE ON "@"
31900 JRST LREND
32000 LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
32100 JRST LRMORE
32200 CAIE A,TAB
32300 CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
32400 JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
32500 JRST LRTY]
32600 CAIE A,CR ;ALWAYS IGNORE CR.S
32700 TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
32800 JRST LRTY
32900 LREND: HRRZ A,B ;FINALLY GOT THERE
33000 JRST NCONS
33100 LRMORE: HRLI B,0
33200 PUSH P,B ;MORE TO GO, PUSH
33300 PUSHJ P,LINRD ;AND CALL YOURSELF
33400 POP P,B
33500 JRST XCONS
33600 LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
33700 JRST LRTY
33800
33900 PAGE
34000 ;NEW AND SUBER BITCHEN READ MACROS
34100 ;
34200 RMACRO:
34300 IFN ALVINE,<
34400 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
34500 JRST RATOM2 ;$$ YES, IGNORE>
34600 RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
34700 PUSHJ P,IDEND ;$$
34800 PUSHJ P,INTER0 ;$$
34900 MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
35000 MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
35100 PUSHJ P,GET ;$$
35200 JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
35300 PUSHJ P,NCONS ;$$ CONVERT TO A FORM
35400 PUSH P,PSAV ;$$
35500 PUSHJ P,EVAL ;$$ EVALUATE THE FORM
35600 POP P,PSAV ;$$
35700 POPJ P, ;$$ RETURN
35800
35900 ;SPECIAL PROCESSING OF SPLICE MACROS
36000 SMACRO:
36100 IFN ALVINE,<
36200 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
36300 JRST RATOM2 ;$$ YES, IGNORE>
36400 PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
36500 MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
36600 JRST RATOM ;$$ START OVER
36700
36800 ;GET AN ITEM OFF OF THE SPLICE LIST
36900 PSMAC: MOVE A,SMAC ;$$
37000 PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
37100 JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
37200 PUSHJ P,NCONS ;$$
37300 MOVEM A,SMAC ;$$
37400 MOVEI B,4 ;$$
37500 JRST RATOM3+1] ;$$
37600 MOVE B,@SMAC ;$$
37700 HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
37800 HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
37900 POPJ P, ;$$ RETURN
38000 PAGE
38100 ;number scanner
38200 NUMTAB: PUSHJ P,COMMENT ;0 comment
38300 JRST RDNUM+1 ;1 null
38400 JRST NUMAK ;2 delimit
38500 JRST RDNDOT ;3 dot
38600 JRST RDE ;4 e
38700 RDNUM: IDPB A,C ;5 digit
38800 PUSHJ P,TYID
38900 LDB B,NUMFLD
39000 JRST NUMTAB(B)
39100
39200 RDNDOT: TLOE T,SAWDOT
39300 JRST NUMAK ;two dots - delimit
39400 MOVEI A,0
39500 JRST RDNUM
39600
39700 RDNMIN: TLO T,MINSGN
39800 RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
39900 JRST RDNUM+1
40000
40100 ;exponent scanner
40200 RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
40300 JRST .+3
40400 MOVEM A,OLDCH
40500 JRST KLDG1
40600 TLO T,EXP
40700 MOVEI A,0
40800 IDPB A,C
40900 PUSHJ P,TYID
41000 CAIN A,"-"
41100 TLOA T,NEXP
41200 CAIN A,"+"
41300 JRST RDE2+1
41400 JRST RDE2+2
41500
41600 EXPTAB: PUSHJ P,COMMENT ;0
41700 JRST RDE2+1 ;1 null
41800 JRST NUMAK ;2 delimit
41900 RDE2: IDPB A,C ;3 digit
42000 PUSHJ P,TYID
42100 LDB B,EXPFLD
42200 JRST EXPTAB(B)
42300 PAGE
42400 ;semantic routines
42500 ;identifier interner and builder
42600
42700 IDEND: TDZA A,A
42800 IDEND1: IDPB A,C
42900 TLNE C,760000
43000 JRST IDEND1
43100 POPJ P,
43200
43300 MAKID: MOVEM A,OLDCH
43400 PUSHJ P,IDEND
43500 SKIPE NOINFG
43600 JRST NOINTR ;dont intern it
43700 INTER0: PUSHJ P,IDSUB
43800 PUSHJ P,INTER1 ;is it in oblist
43900 POPJ P, ;found
44000 PUSHJ P,PNAMAK ;not there
44100 MAKID2: MOVE C,CURBUC# ;
44200 HLRZ B,@RHX2
44300 PUSHJ P,CONS ;cons it into the oblist
44400 HRLM A,@RHX2
44500 JRST CAR
44600
44700 ;pname unmaker
44800 PNAMUK:
44900 MOVEI B,PNAME(S)
45000 PUSHJ P,GET
45100 JUMPE A,NOPNAM
45200 MOVE C,SP
45300 PNAMU3: HLRZ B,(A)
45400 PUSH C,(B)
45500 HRRZ A,(A)
45600 JUMPN A,PNAMU3
45700 POPJ P,
45800
45900 ;idsub constructs a iowd pointer for a print name
46000 IDSUB: HRRZS C
46100 CAML C,JRELO ;top of spec pdl
46200 JRST SPDLOV
46300 MOVNS C
46400 ADDI C,(SP)
46500 HRLI C,1(SP)
46600 MOVSM C,IDPTR#
46700 POPJ P,
46800
46900 PAGE ;identifier interner
47000 INTER1: MOVE B,1(SP) ;get first word of pname
47100 LSH B,-1 ;right justify it
47200 IDIV B,INT1 ;compute hash code
47300 REMOTE<
47400 INT1: BCKETS
47500 RHX2:
47600 XXX1: XWD B+1,OBTBL>
47700 HLRZ TT,@RHX2 ;get bucket
47800 MOVEM B+1,CURBUC ;save bucket number
47900 MOVE T,TT
48000 JRST MAKID1
48100
48200 MAKID3: MOVE TT,T ;save previous atom
48300 HRRZ T,(T) ;get next atom
48400 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
48500 HLRZ A,(T) ;next id in oblist
48600 MAKID4: HRRZ A,(A)
48700 JUMPE A,NOPNAM ;no print name
48800 MOVE A,(A)
48900 HLRZ C,A
49000 CAIE C,PNAME(S)
49100 JRST MAKID4
49200 MOVE C,IDPTR ;found pname
49300 HLRZ A,(A)
49400 MAKID5: JUMPE A,MAKID3 ;not the one
49500 MOVS A,(A)
49600 MOVE B,(A)
49700 ANDCAM AR1,(C) ;clear low bit
49800 CAME B,(C)
49900 JRST MAKID3 ;not the one
50000 HLRZ A,A ;ok so far
50100 AOBJN C,MAKID5
50200 JUMPN A,MAKID3 ;not the one
50300 HLRZ A,(T) ;this is it
50400 HLRZ B,(TT)
50500 HRLM A,(TT)
50600 HRLM B,(T)
50700 POPJ P,
50800
50900 ;pname builder
51000 PNAMAK: MOVE T,IDPTR
51100 PUSHJ P,NCONS
51200 MOVE TT,A
51300 MOVE C,A
51400 PNAMB: MOVE A,(T)
51500 TRZ A,1 ;clear low bit!!!!!
51600 PUSHJ P,FWCONS
51700 PUSHJ P,NCONS
51800 HRRM A,(TT)
51900 MOVE TT,A
52000 AOBJN T,PNAMB
52100 MOVE A,C
52200 HRLZS (A)
52300 JRST PNGNK1+1
52400 PAGE
52500 ;number builder
52600 NUMAK: MOVEM A,OLDCH
52700 HRRI R,NUMCLS ;number
52800 CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
52900 JRST .+5
53000 KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
53100 IDPB A,C
53200 PUSHJ P,TYIA
53300 JRST RDID+2
53400 MOVEI A,0
53500 IDPB A,C
53600 IDPB A,C
53700 HRRZS C
53800 CAML C,JRELO ;top of spec pdl
53900 JRST SPDLOV
54000 MOVSI C,(POINT 7,0,35)
54100 HRRI C,(SP)
54200 TLNE T,SAWDOT+EXP
54300 JRST NUMAK2 ;decimal number or flt pt
54400 MOVE A,VIBASE(S) ;ibase integrer
54500 SUBI A,INUM0
54600 PUSHJ P,NUM
54700 NUMAK4:
54800 MOVEI B,FIXNUM(S)
54900 NUMAK6: TLNE T,MINSGN
55000 MOVNS A
55100 JRST MAKNUM
55200
55300 NUMAK2: PUSHJ P,NUM10
55400 MOVEM A,TT
55500 TLNN T,SAWDOT
55600 JRST [ PUSHJ P,FLOAT ;flt pt without fraction
55700 MOVE TT,A
55800 JRST NUMAK3]
55900 PUSHJ P,NUM10 ;fraction part
56000 EXCH A,TT
56100 TLNN T,EXP
56200 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
56300 PUSHJ P,FLOAT
56400 EXCH A,TT
56500 PUSHJ P,FLOAT
56600 MOVEI AR1,FT01
56700 PUSHJ P,FLOSUB
56800 FMPR A,B
56900 FADRM A,TT
57000 NUMAK3: PUSHJ P,NUM10 ;exponent part
57100 MOVE AR2A,A
57200 MOVEI AR1,FT-1
57300 TLNE T,NEXP
57400 MOVEI AR1,FT01 ;-exponent
57500 PUSHJ P,FLOSUB
57600 FMPR TT,B ;positive exponent
57700 MOVEI B,FLONUM(S)
57800 MOVE A,TT
57900 JFCL 10,FLOOV
58000 JRST NUMAK6
58100
58200 FLOSUB: MOVSI B,(1.0)
58300 TRZE AR2A,1
58400 FMPR B,(AR1)
58500 JUMPE AR2A,CPOPJ
58600 LSH AR2A,-1
58700 SOJA AR1,FLOSUB+1
58800
58900 ;variable radix integer builder
59000
59100 NUM10: MOVEI A,TEN
59200 NUM: HRRM A,NUM1
59300 JFCL 10,.+1 ;clear carry0 flag
59400 SETZB A,AR2A
59500 NUM2: ILDB B,C
59600 JUMPE B,CPOPJ ;done
59700 IMUL A,NUM1#
59800 ADDI A,-"0"(B)
59900 NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
60000 AOJA AR2A,NUM2
60100 PAGE
60200 INTERN: MOVEM A,AR2A
60300 PUSHJ P,PNAMUK
60400 PUSHJ P,IDSUB
60500 MOVEI AR1,1
60600 PUSHJ P,INTER1 ;is it in oblist
60700 POPJ P, ;found it
60800 MOVE A,AR2A ;not there
60900 JRST MAKID2 ;put it there
61000
61100 REMOB: JUMPE A,FALSE
61200 MOVEI AR1,1
61300 PUSH P,A
61400 HLRZ A,(A)
61500 PUSHJ P,INTERN
61600 HLRZ B,@(P)
61700 CAME A,B
61800 JRST REMOB2
61900 HRRZ B,CURBUC
62000 REMOTE<
62100 RHX5:
62200 XXX2: XWD B,OBTBL>
62300 HLRZ C,@RHX5
62400 HLRZ T,(C)
62500 CAMN T,A
62600 JRST [ HRRZ TT,(C)
62700 HRLM TT,@RHX5
62800 JRST REMOB2]
62900 REMOB3: MOVE TT,C
63000 HRRZ C,(C)
63100 HLRZ T,(C)
63200 CAME T,A
63300 JRST REMOB3
63400 HRRZ T,(C)
63500 HRRM T,(TT)
63600 REMOB2: POP P,A
63700 HRRZ A,(A)
63800 JRST REMOB
63900 PAGE
64000 ;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
64100 ;READ CHARACTER-TABLE BY LISP FUNCTIONS
64200 ;TAKES TWO ARGUMENTS A,B
64300 ; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
64400 ; LOCATION SPECIFIED BY A
64500 ; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
64600 ; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
64700 ; PREVIOUS VALUE
64800
64900 MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
65000 PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
65100 POP P,B ;$$
65200 MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
65300 JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
65400 PUSH P,A ;$$SAVE TABLE POSITION
65500
65600 MOVEI A,(B) ;$$
65700 PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
65800 POP P,B ;$$GET TABLE POSITION
65900 MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
66000 MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
66100 JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
66200
66300 ;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
66400 ; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
66500 ; CHARACTER OF THE PRINT NAME
66600 CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
66700 PUSHJ P,GET ;$$
66800 HLRZ A,(A) ;$$
66900 MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
67000 LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
67100 JRST FIX1A ;$$ CONVERT TO INTEGER
67200
67300 ;FUNCTION TO SET BITS FOR A READ MACRO
67400 ; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
67500 ; IF B=NIL NO MODIFICATION IS MADE
67600 ; THE OLD STATUS BITS ARE RETURNED
67700 SETCHR: MOVE TT,B ;$$
67800 PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
67900 MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
68000 LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
68100 JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
68200 MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
68300 DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
68400 JRST FIX1A ;$$ RETURN
68500
68600
68700 SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
68800 PAGE
68900
69000 CADDDR: SKIPA A,(A)
69100 CADDAR: HLRZ A,(A)
69200 CADDR: SKIPA A,(A)
69300 CADAR: HLRZ A,(A)
69400 CADR: SKIPA A,(A)
69500 CAAR: HLRZ A,(A)
69600 CAR: HLRZ A,(A)
69700 POPJ P,
69800
69900 CDDDDR: SKIPA A,(A)
70000 CDDDAR: HLRZ A,(A)
70100 CDDDR: SKIPA A,(A)
70200 CDDAR: HLRZ A,(A)
70300 CDDR: SKIPA A,(A)
70400 CDAR: HLRZ A,(A)
70500 CDR: HRRZ A,(A)
70600 POPJ P,
70700
70800 CAADDR: SKIPA A,(A)
70900 CAADAR: HLRZ A,(A)
71000 CAADR: SKIPA A,(A)
71100 CAAAR: HLRZ A,(A)
71200 JRST CAAR
71300
71400 CDADDR: SKIPA A,(A)
71500 CDADAR: HLRZ A,(A)
71600 CDADR: SKIPA A,(A)
71700 CDAAR: HLRZ A,(A)
71800 JRST CDAR
71900
72000 CAAADR: SKIPA A,(A)
72100 CAAAAR: HLRZ A,(A)
72200 JRST CAAAR
72300
72400 CDDADR: SKIPA A,(A)
72500 CDDAAR: HLRZ A,(A)
72600 JRST CDDAR
72700
72800 CDAADR: SKIPA A,(A)
72900 CDAAAR: HLRZ A,(A)
73000 JRST CDAAR
73100
73200 CADADR: SKIPA A,(A)
73300 CADAAR: HLRZ A,(A)
73400 JRST CADAR
73500 PAGE
73600
73700 QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
73800 POPJ P,
73900
74000 AASCII: PUSHJ P,NUMVAL
74100 LSH A,↑D29
74200 PUSHJ P,FWCONS
74300 PUSHJ P,NCONS
74400 PNGNK1: PUSHJ P,NCONS
74500 MOVEI B,PNAME(S)
74600 PUSHJ P,XCONS
74700 ACONS: TROA B,-1
74800 NCONS: TRZA B,-1
74900 XCONS: EXCH B,A
75000 CONS: AOS CONSVAL
75100 HRL B,A
75200 SKIPN A,F
75300 JRST [ HLR A,B
75400 PUSHJ P,AGC
75500 JRST .-1]
75600 MOVE F,(F)
75700 MOVEM B,(A)
75800 POPJ P,
75900
76000 ;new consing routines-not finished yet
76100 ;acons: troa b,-1
76200 ;ncons: trz b,-1
76300 ;cons: exch b,a
76400 ;xcons: hrl a,b
76500 ; exch a,(f)
76600 ; exch a,f
76700 ; popj p,
76800
76900 CONSP: CAILE A,INUMIN
77000 JRST FALSE
77100 HLLE A,(A)
77200 AOJE A,FALSE
77300 JRST TRUE
77400 PATOM: CAIL A,@GCP1
77500 JRST TRUE
77600 CAIL A,@GCPP1
77700 ATOM: CAILE A,INUMIN
77800 JRST TRUE
77900 HLLE A,(A)
78000 AOJE A,TRUE
78100 JRST FALSE
78200 PAGE
78300 NEQ: CAMN A,B
78400 JRST FALSE
78500 JRST TRUE
78600 EQ: CAMN A,B
78700 JRST TRUE
78800 JRST FALSE
78900
79000 LENGTH: MOVEI B,0
79100 LNGTH1: CAILE A,INUMIN
79200 JRST FIX1
79300 HLLE C,(A)
79400 AOJE C,FIX1
79500 HRRZ A,(A)
79600 AOJA B,LNGTH1
79700
79800 LAST: HRRZ B,(A)
79900 CAILE B,INUMIN
80000 POPJ P,
80100 HLLE B,(B)
80200 AOJE B,CPOPJ
80300 HRRZ A,(A)
80400 JRST LAST
80500
80600 ;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
80700 LITATOM:MOVE B,A
80800 PUSHJ P,ATOM
80900 JUMPE A,CPOPJ
81000 MOVE A,B
81100 PUSHJ P,NUMBERP
81200 JRST NOT
81300 PAGE
81400 ;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
81500 RPLACA: CAILE A,INUMIN ;$$
81600 JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
81700 HLL A,(A) ;$$TEST FOR OTHER ATOMS
81800 TLC A,-1 ;$$
81900 TLZN A,-1 ;$$ATOM CARS ARE -1
82000 JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
82100 HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
82200 POPJ P, ;$$
82300
82400 RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
82500 JUMPN A,.+2 ;$$CHECK FOR NIL
82600 JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
82700 HRRM B,(A) ;$$OLD RPLACD CODE
82800 POPJ P, ;$$
82900
83000 ZEROP: PUSHJ P,NUMVAL
83100 NOT:
83200 NULL: JUMPN A,FALSE
83300 TRUE:
83400 MOVEI A,TRUTH(S)
83500 POPJ P,
83600
83700 FW0CNS: MOVEI A,0
83800 FWCONS: JUMPN FF,FWC1
83900 EXCH A,FWC0#
84000 PUSHJ P,AGC
84100 EXCH A,FWC0
84200 FWC1: EXCH A,(FF)
84300 EXCH A,FF
84400 POPJ P,
84500
84600 PAGE
84700 SASSOC: PUSHJ P,SAS1
84800 JCALLF 0,(C)
84900 POPJ P,
85000
85100 SAS0: HLRZ B,T
85200 SAS1: JUMPE B,CPOPJ
85300 MOVS T,(B)
85400 MOVS TT,(T)
85500 CAIE A,(TT)
85600 JRST SAS0
85700 HRRZ A,T
85800 CPOPJ1: AOS (P)
85900 POPJ P,
86000
86100 ASSOC: PUSHJ P,SAS1
86200 FALSE: MOVEI A,NIL
86300 CPOPJ: POPJ P,
86400
86500 REVERSE: MOVE T,A
86600 MOVEI A,0
86700 JUMPE T,CPOPJ
86800 HLRZ B,(T)
86900 HRRZ T,(T)
87000 PUSHJ P,XCONS
87100 JUMPN T,.-3
87200 POPJ P,
87300
87400
87500 REMPROP: HRRZ T,(A)
87600 MOVS TT,(T)
87700 CAIN B,(TT)
87800 JRA TT,REMP1
87900 HLRZ A,TT
88000 HRRZ T,(A)
88100 JUMPN T,REMPROP+1
88200 JRST FALSE
88300
88400 REMP1: HRRM TT,(A)
88500 JRST TRUE
88600 PAGE
88700 GET: HRRZ A,(A)
88800 MOVS D,(A)
88900 CAIN B,(D)
89000 JRST CADR
89100 HLRZ A,D
89200 HRRZ A,(A)
89300 JUMPN A,GET+1
89400 POPJ P,
89500
89600 GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
89700 HRRZ A,(A)
89800 GETL0: HLRZ T,(A)
89900 MOVE C,B
90000 GETL1: MOVS TT,(C)
90100 CAIN T,(TT)
90200 POPJ P,
90300 HLRZ C,TT
90400 JUMPN C,GETL1
90500 HRRZ A,(A)
90600 HRRZ A,(A)
90700 JUMPN A,GETL0
90800 POPJ P,
90900
91000 NUMBERP: CAILE A,INUMIN
91100 JRST TRUE
91200 HLLE T,(A)
91300 AOJN T,FALSE
91400 HRRZ A,(A)
91500 HLRZ A,(A)
91600 CAIE A,FIXNUM(S)
91700 CAIN A,FLONUM(S)
91800 JRST TRUE
91900 NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
92000 STRINGP: MOVE B,A ;= T IF A IS A STRING
92100 PUSHJ P,ATOM
92200 JUMPE A,CPOPJ
92300 MOVE A,B
92400 PUSHJ P,NUMBERP ;MUST NO BE A NUMBER
92500 JUMPN A,FALSE
92600 MOVE A,B
92700 PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
92800 CAIE A,42+INUM0 ;CHECK FOR "
92900 JRST FALSE
93000 JRST TRUE
93100 PAGE
93200 PUTPROP: MOVE T,A
93300 HRRZ A,(A)
93400 CSET3: MOVS TT,(A)
93500 HLRZ A,TT
93600 CAIN C,(TT)
93700 JRST CSET2
93800 HRRZ A,(A)
93900 JUMPN A,CSET3
94000 HRRZ A,(T)
94100 PUSHJ P,XCONS
94200 HRRZ B,C
94300 PUSHJ P,XCONS
94400 HRRM A,(T)
94500 JRST CADR
94600
94700 CSET2:
94800 CAIE C,VALUE(S)
94900 JRST CSET1
95000 HRRZ T,(B)
95100 HLRZ A,(A)
95200 HRRM T,(A)
95300 JRST PROG2
95400
95500 CSET1: HRLM B,(A)
95600 PROG2: MOVE A,B
95700 PROG1: POPJ P,
95800
95900 DEFPROP:
96000 HRRZ B,(A)
96100 HRRZ C,(B)
96200 HLRZ A,(A)
96300 HLRZ B,(B)
96400 HLRZ C,(C)
96500 PUSH P,A
96600 PUSHJ P,PUTPROP
96700 JRST POPAJ
96800 PAGE
96900 EQUAL: MOVE C,P
97000 EQUAL1: CAMN A,B
97100 JRST TRUE
97200 MOVE T,A
97300 MOVE TT,B
97400 PUSHJ P,ATOM
97500 EXCH A,B
97600 PUSHJ P,ATOM
97700 CAMN A,B
97800 JRST EQUAL3
97900 EQUAL4: MOVE P,C
98000 JRST FALSE
98100
98200 EQUAL3: JUMPN A,EQ2
98300 PUSH P,T
98400 PUSH P,TT
98500 HLRZ A,(T)
98600 HLRZ B,(TT)
98700 PUSHJ P,EQUAL1
98800 JUMPE A,EQUAL4
98900 POP P,B
99000 POP P,A
99100 HRRZ A,(A)
99200 HRRZ B,(B)
99300 JRST EQUAL1
99400
99500 EQ2: PUSH P,T
99600 MOVE A,T
99700 PUSHJ P,NUMBERP
99800 JUMPE A,EQUAL4
99900 MOVE A,TT
00100 PUSHJ P,NUMBERP
00200 JUMPE A,EQUAL4
00300 MOVE A,(P)
00400 MOVEM C,(P)
00500 MOVE B,TT
00600 JSP C,OP
00700 JUMPL COMP3
00800 JUMPL COMP3
00900
01000 COMP3: POP P,C
01100 CAME A,TT
01200 JRST EQUAL4
01300 JRST TRUE
01400 PAGE
01500 SUBS5: HRRZ A,SUBAS
01600 POPJ P,
01700
01800 SUBST: MOVEM A,SUBAS#
01900 MOVEM B,SUBBS#
02000 SUBS0A: MOVE A,SUBAS
02100 MOVE B,SUBBS
02200 PUSH P,C
02300 MOVE A,C
02400 PUSHJ P,EQUAL
02500 POP P,C
02600 JUMPN A,SUBS5
02700 CAILE C,INUMIN
02800 JRST EV6A
02900 HLLE T,(C)
03000 AOJN T,SUBS2
03100 EV6A: MOVE A,C
03200 POPJ P,
03300
03400 SUBS2: PUSH P,C
03500 HLRZ C,(C)
03600 PUSHJ P,SUBS0A
03700 EXCH A,(P)
03800 HRRZ C,(A)
03900 PUSHJ P,SUBS0A
04000 POP P,B
04100 JRST XCONS
04200
04300 COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
04400 MOVEI C,INUM0
04500 EXCH A,C
04600 JRST SUBST
04700
04800 ; NTHCHAR = THE BTH CHARACTER OF A.
04900 NTHCHAR:MOVE T,B
05000 SUBI T,INUM0
05100 JUMPE T,FALSE ;FAIL IF = 0
05200 PUSH P,A
05300 MOVEM T,ORGSGN
05400 JUMPG T,NTH3
05500 PUSHJ P,%FLATSIZEC
05600 MOVEI T,1-INUM0(A)
05700 ADDB T,ORGSGN
05800 NTH3: MOVE A,(P)
05900 PUSHJ P,LITATOM
06000 JUMPN A,NTH4
06100 POP P,A
06200 HRROI R,NTH5 ;I HOPE THIS IS RIGHT
06300 PUSHJ P,PRINTA
06400 HLRZ A,ORGSGN
06500 JRST NTH6
06600 NTH5: SOSN ORGSGN
06700 HRLOM A,ORGSGN
06800 POPJ P,
06900 NTH4: MOVE T,ORGSGN
07000 POP P,A
07100 MOVEI B,PNAME(S)
07200 PUSHJ P,GET
07300 JUMPE A,CPOPJ ;FAIL IF NO PRINT NAME
07400 NTH1: CAIG T,5
07500 JRST NTH2
07600 HRRZ A,(A)
07700 JUMPE A,FALSE ;FAIL IF NO NTH CHARACTER
07800 SUBI T,5
07900 JRST NTH1
08000 NTH2: HLRZ A,(A)
08100 IMULI T,-7
08200 LSH T,14
08300 ADDI T,440700
08400 HRL A,T
08500 LDB A,A
08600 JUMPE A,FALSE
08700 NTH6: PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
08800 JRST INTERN ;INTERN IT
08900 PAGE
09000 NCONC: TDZA R,R
09100 APPEND: MOVEI R,.APPEND-.NCONC
09200 JUMPE T,FALSE
09300 POP P,B
09400 APP2: AOJE T,PROG2
09500 POP P,A
09600 PUSHJ P,.NCONC(R)
09700 MOVE B,A
09800 JRST APP2
09900
10000 .NCONC: JUMPE A,PROG2
10100 MOVE TT,A
10200 MOVE C,TT
10300 HRRZ TT,(C)
10400 JUMPN TT,.-2
10500 HRRM B,(C)
10600 POPJ P,
10700
10800 .APPEND: JUMPE A,PROG2
10900 MOVEI C,AR1
11000 MOVE TT,A
11100 APP1: HLRZ A,(TT)
11200 PUSH P,B
11300 PUSHJ P,CONS ;saves b
11400 POP P,B
11500 HRRM A,(C)
11600 MOVE C,A
11700 HRRZ TT,(TT)
11800 JUMPN TT,APP1
11900 JRST SUBS4
12000 PAGE
12100 MEMBER: MOVEM A,SUBAS
12200 MEMB1: JUMPE B,FALSE
12300 MOVEM B,SUBBS
12400 MOVE A,SUBAS
12500 HLRZ B,(B)
12600 PUSHJ P,EQUAL
12700 JUMPN A,CPOPJ
12800 MOVE B,SUBBS
12900 HRRZ B,(B)
13000 JRST MEMB1
13100
13200 MEMQ: JUMPE B,FALSE
13300 MOVS C,(B)
13400 CAIN A,(C)
13500 JRST TRUE
13600 HLRZ B,C
13700 JUMPN B,MEMQ+1
13800 JRST FALSE
13900
14000
14100
14200 ;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
14300 ; THE ELEMENT IS FOUND
14400
14500 MEMBR.: PUSHJ P,MEMBER
14600 SKIPE A
14700 MOVE A,SUBBS
14800 POPJ P,
14900
15000 MEMB: PUSHJ P,MEMQ
15100 SKIPE A
15200 MOVE A,B
15300 POPJ P,
15400
15500
15600 ;NEW AND AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
15700 ; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
15800
15900 AND.: PUSHJ P,AND
16000 SKIPA
16100 OR.: PUSHJ P,OR
16200 HRRZ A,2(P)
16300 POPJ P,
16400
16500 AND:
16600 HRLI A,TRUTH(S)
16700 OR: HLRZ C,A
16800 PUSH P,C
16900 ANDOR: HRRZ C,A
17000 JUMPE C,AOEND
17100 MOVSI C,(SKIPE (P))
17200 TLNE A,-1
17300 MOVSI C,(SKIPN (P))
17400 XCT C
17500 JRST AOEND
17600 MOVEM A,(P)
17700 HLRZ A,(A)
17800 PUSHJ P,EVAL
17900 EXCH A,(P)
18000 HRR A,(A)
18100 JRST ANDOR
18200
18300 AOEND: POP P,A
18400 SKIPE A
18500 MOVEI A,TRUTH(S)
18600 POPJ P,
18700 GENSYM: MOVE B,[POINT 7,GNUM,34]
18800 MOVNI C,4
18900 MOVEI TT,"0"
19000
19100 GENSY2: LDB T,B
19200 AOS T
19300 DPB T,B
19400 CAIG T,"9"
19500 JRST GENSY1
19600 DPB TT,B
19700 ADD B,[XWD 70000,0]
19800 AOJN C,GENSY2
19900
20000 GENSY1: MOVE A,GNUM
20100 PUSHJ P,FWCONS
20200 PUSHJ P,NCONS
20300 JRST PNGNK1
20400
20500 REMOTE<
20600 GNUM: ASCII /G0000/>
20700
20800 CSYM: HLRZ A,(A)
20900 PUSH P,A
21000 MOVEI B,PNAME(S)
21100 PUSHJ P,GET
21200 JUMPE A,NOPNAM
21300 HLRZ A,(A)
21400 MOVE A,(A)
21500 MOVEM A,GNUM
21600 JRST POPAJ
21700 PAGE
21800 LIST: MOVEI B,CEVAL(S)
21900 PUSH P,B
22000 PUSH P,A
22100 MOVNI T,2
22200 JRST MAPCAR
22300
22400 EELS: HLRZ TT,(T) ;interpret lsubr call
22500 HRRZ A,(AR1)
22600 ILIST: MOVEI T,0
22700 JUMPE A,ILIST2
22800 ILIST1: PUSH P,A
22900 HLRZ A,(A)
23000 PUSH P,TT
23100 HRLM T,(P)
23200 PUSH P,SP ;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
23300 PUSHJ P,EVAL ;EVALUATE ARGUMENT
23400 POP P,SP ;$$RESTORE SP POINTER AFTER EVAL
23500 ILIST3: POP P,TT
23600 HLRE T,TT
23700 EXCH A,(P)
23800 HRRZ A,(A)
23900 SOS T
24000 JUMPN A,ILIST1
24100 ILIST2: JRST (TT)
24200
24300 ;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
24400 .MAPC: PUSH P,A
24500 JUMPE B,PRETB
24600 HLRZ A,(B)
24700 HRRZ B,(B)
24800 PUSH P,B
24900 CALLF 1,@-1(P)
25000 POP P,B
25100 JRST .MAPC+1
25200
25300 ;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
25400 .MAP: PUSH P,A
25500 JUMPE B,PRETB
25600 MOVE A,B
25700 HRRZ B,(B)
25800 PUSH P,B
25900 CALLF 1,@-1(P)
26000 POP P,B
26100 JRST .MAP+1
26200
26300 PRETB: SUB P,[XWD 1,1]
26400 JRST PROG2
26500 PAGE
26600 ; NEW AND SUPER POWERFUL MAP FUNCTIONS
26700 MAPCON: TLZ T,100000
26800 JRST MAPLIST
26900 MAPCAN: TLZA T,100000
27000 MAPC: TLZA T,400000
27100 MAPCAR: TLZA T,400000
27200 MAP: TLZ T,200000
27300 ; INITIALIZE
27400 MAPLIST:SETCA T,T
27500 MOVEI A,(CALLF)
27600 DPB T,[POINT 4,A,30]
27700 MOVE B,P
27800 MOVE AR1,T
27900 HRL AR1,T
28000 SUB B,AR1
28100 PUSH P,B
28200 HRLM A,(B)
28300 PUSH P,T
28400 PUSH P,
28500 HRLZM P,(P)
28600 ; SET UP TO GET ARGUMENTS
28700 MAPL2: HRRZ T,-1(P)
28800 MOVEI TT,-3(P)
28900 ; MOVE ARGS TO REGS
29000 MPL3: MOVE D,(TT)
29100 JUMPE D,MPDN
29200 MOVEM D,(T)
29300 MOVE D,(D)
29400 SKIPGE -1(P)
29500 HLRZM D,(T)
29600 HRRZM D,(TT)
29700 SUBI TT,1
29800 SOJG T,MPL3
29900 XCT (TT) ; CALL THE FUNCTION
30000 LDB C,[POINT 2,-1(P),2]
30100 TRNE C,2
30200 JRST MAPL2
30300 ; ATTACH TO OUTPUT LIST
30400 SKIPN C
30500 PUSHJ P,NCONS
30600 JUMPE A,MAPL2
30700 HLR B,(P)
30800 HRRM A,(B)
30900 SKIPE C
31000 PUSHJ P,LAST
31100 HRLM A,(P)
31200 JRST MAPL2
31300 ; POP STACK AND RETURN
31400 MPDN: POP P,AR1
31500 MOVE P,-1(P)
31600 POP P,B
31700 SUBS4: HRRZ A,AR1
31800 POPJ P,
31900 ;PA3: 0 ;THE REG. PDL POINTER
32000 ;PA4: 0 ;Lh=pntr to prog less bound var list
32100 ;RH=NEXT PROG STATEMENT
32200
32300 PROG: PUSH P,PA3#
32400 PUSH P,PA4#
32500 HLRZ TT,(A)
32600 HRRZ A,(A)
32700 HRRM A,PA4
32800 HRLM A,PA4
32900
33000 MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
33100 SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
33200 MOVEM T,SPSV# ;$$BY UNBIND
33300 JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
33400
33500 PG7A: HLRZ A,(TT)
33600 MOVEI AR1,0
33700 PUSHJ P,BIND
33800 HRRZ TT,(TT)
33900 PG7B: JUMPN TT,PG7A
34000 PUSH SP,SPSV
34100 MOVEM P,PA3
34200
34300 PG1: HRRZ T,PA4
34400 JUMPE T,PG4
34500 HLRZ A,(T)
34600 HRRZ T,(T)
34700 HLLE B,(A)
34800 AOJE B,PG1+1
34900 HRRM T,PA4
35000
35100 PUSH P,SP ;$$SAVE SPDL TO RESTORE AFTER EVAL
35200 PUSHJ P,EVAL
35300 POP P,SP ;$$RESTORE SPDL AFTER EVAL
35400
35500 JRST PG1
35600
35700 PGO: SKIPN PA3
35800 JRST EG2
35900 MOVE P,PA3
36000 MOVE B,1(P)
36100 PUSHJ P,UBD
36200 HLRZ T,PA4
36300 PG5: JUMPE T,EG1
36400 HLRZ TT,(T)
36500 HRRZ T,(T)
36600 CAIN TT,(A)
36700 JRST PG1+1 ;FOUND TAG
36800 JRST PG5
36900
37000 RETURN: SKIPN PA3
37100 JRST EG3
37200 MOVE P,PA3
37300 MOVE B,1(P)
37400 PUSHJ P,UBD
37500 JRST PG4+1
37600 PG4: SETZ A,
37700 PUSHJ P,UNBIND
37800 ERRP4: POP P,PA4
37900 POP P,PA3
38000 POPJ P,
38100
38200 GO: HLRZ A,(A)
38300 HLLE B,(A)
38400 AOJE B,PGO
38500 PUSHJ P,EVAL
38600 JRST GO+1
38700
38800
38900 SETQ: HLRZ B,(A)
39000 PUSH P,B
39100 PUSHJ P,CADR
39200 PUSHJ P,EVAL
39300 MOVE B,A
39400 POP P,A
39500 SET: SKIPE A ;$$ MUST BE NON-NIL
39600 CAILE A,INUMIN ;$$ AND NOT AN INUM
39700 JRST SETERR ;$$
39800 HLRE AR1,(A) ;$$ AND AN ATOM
39900 AOJN AR1,SETERR ;$$
40000 MOVE AR1,B
40100 PUSHJ P,BIND
40200 SUB SP,[XWD 1,1]
40300 MOVE A,AR1
40400 POPJ P,
40500
40600 CON2: HRRZ A,(T)
40700 COND: JUMPE A,CPOPJ ;entry
40800 PUSH P,A
40900 HLRZ A,(A)
41000 HLRZ A,(A)
41100 PUSHJ P,EVAL
41200 POP P,T
41300 JUMPE A,CON2
41400 HLRZ T,(T)
41500 COND2: HRRZ T,(T)
41600 JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
41700 HLRZ A,(T)
41800 HRRZ T,(T) ;$$
41900 JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
42000 PUSH P,T ;$$
42100 PUSHJ P,EVAL
42200 POP P,T
42300 JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
42400
42500
42600 ;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
42700
42800 LEXORD: MOVE TT,A
42900 PUSHJ P,NUMBERP
43000 JUMPN A,LEX2 ;1ST ARG IS A NUMBER
43100 MOVE A,B
43200 PUSHJ P,NUMBERP
43300 EXCH A,TT
43400 JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
43500 MOVE T,B
43600 MOVEI B,PNAME(S)
43700 PUSHJ P,GET
43800 EXCH A,T
43900 PUSHJ P,GET
44000 LEX1: JUMPE T,TRUE
44100 JUMPE A,CPOPJ
44200 HLRZ AR1,(A)
44300 MOVE AR1,(AR1)
44400 HLRZ AR2A,(T)
44500 MOVE AR2A,(AR2A)
44600 LSH AR1,-1
44700 LSH AR2A,-1
44800 CAMLE AR1,AR2A
44900 JRST TRUE
45000 CAME AR1,AR2A
45100 JRST FALSE
45200 HRRZ A,(A)
45300 HRRZ T,(T)
45400 JRST LEX1
45500 LEX2: MOVE A,B
45600 PUSHJ P,NUMBERP
45700 EXCH A,TT
45800 JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
45900 PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
46000 JRST NOT
46100
46200
46300 PROGN: MOVE T,A ;$$ PROGN
46400 MOVEI A,NIL
46500 JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
46600 PAGE
46700 SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
46800
46900 ;macro expander -- (foo a b c) => (*foo (*foo a b) c)
47000 EXPAND: MOVE C,B
47100 HRRZ A,(A)
47200 PUSHJ P,REVERSE
47300 JRST EXPA1
47400
47500 EXPN1: MOVE C,B
47600 EXPA1: HRRZ T,(A)
47700 HLRZ A,(A)
47800 JUMPE T,CPOPJ
47900 PUSH P,A
48000 MOVE A,T
48100 PUSHJ P,EXPA1
48200 EXCH A,(P)
48300 PUSHJ P,NCONS
48400 POP P,B
48500 PUSHJ P,XCONS
48600 MOVE B,C
48700 JRST XCONS
48800
48900 PAGE
49000
49100 ADD1: CAILE A,INUMIN
49200 CAIL A,-2
49300 SKIPA B,[INUM0+1]
49400 AOJA A,CPOPJ
49500 .PLUS: JSP C,OP
49600 ADD A,TT
49700 FADR A,TT
49800
49900 SUB1: CAILE A,INUMIN+1
50000 SOJA A,CPOPJ
50100 MOVEI B,INUM0+1
50200 .DIF: JSP C,OP
50300 SUB A,TT
50400 FSBR A,TT
50500
50600 .TIMES: JSP C,OP
50700 IMUL A,TT
50800 FMPR A,TT
50900
51000 .QUO: CAIN B,INUM0
51100 JRST ZERODIV
51200 JSP C,OP
51300 IDIV A,TT
51400 FDVR A,TT
51500
51600 .GREAT: EXCH A,B
51700 JUMPE B,FALSE
51800 .LESS: JUMPE A,CPOPJ
51900 JSP C,OP
52000 JRST COMP2 ;bignums know about me
52100 JRST COMP2
52200
52300 COMP2: CAML A,TT
52400 JRST FALSE
52500 JRST TRUE
52600
52700 .MAX: MOVEI D,.GREAT
52800 SKIPA
52900 .MIN: MOVEI D,.LESS
53000 MOVE AR1,A
53100 MOVE AR2A,B
53200 PUSHJ P,(D)
53300 SKIPN A
53400 MOVE AR1,AR2A
53500 MOVE A,AR1
53600 POPJ P,
53700 PAGE
53800 MAKNUM:
53900 CAIN B,FIXNUM(S)
54000 JRST FIX1A
54100 FLO1A:
54200 MOVEI B,FLONUM(S)
54300 PUSHJ P,FWCONS
54400 JRST ACONS-1
54500
54600 FIX1B: SUBI A,INUM0
54700 MOVEI B,FIXNUM(S)
54800 PUSHJ P,FWCONS
54900 JRST ACONS-1
55000
55100 NUMVLX: JFCL 17,.+1
55200 NUMVAL: CAIG A,INUMIN
55300 JRST NUMAG1
55400 SUBI A,INUM0
55500 MOVEI B,FIXNUM(S)
55600 POPJ P,
55700
55800 NUMAG1: MOVEM A,AR1
55900 HRRZ A,(A)
56000 HLRZ B,(A)
56100 HRRZ A,(A)
56200 CAIE B,FIXNUM(S)
56300 CAIN B,FLONUM(S)
56400 SKIPA A,(A)
56500 NUMV4: SKIPA A,AR1
56600 POPJ P,
56700 NUMV2: PUSHJ P,EPRINT ;bignums know about me
56800 JRST NONNUM
56900
57000 NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
57100 PAGE
57200 FLOAT: IDIVI A,400000
57300 SKIPE A
57400 TLC A,254000
57500 TLC B,233000
57600 FADR A,B
57700 POPJ P,
57800
57900 FIX: PUSH P,A
58000 PUSHJ P,NUMVAL
58100 CAIE B,FLONUM(S)
58200 JRST POPAJ
58300 MULI A,400
58400 TSC A,A
58500 JFCL 17,.+1
58600 ASH B,-243(A)
58700 FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
58800 POP P,A
58900 FIX1: MOVE A,B
59000 JRST FIX1A
59100
59200 MINUSP: PUSHJ P,NUMVAL
59300 JUMPGE A,FALSE
59400 JRST TRUE
59500
59600 MINUS: PUSHJ P,NUMVLX
59700 MOVNS A
59800 JFCL 10,@OPOV
59900 JRST MAKNUM
60000
60100 ABS: PUSHJ P,NUMVLX
60200 MOVMS A
60300 JRST MINUS+2
60400 PAGE
60500 DIVIDE: CAIN B,INUM0
60600 JRST ZERODIV
60700 JSP C,OP
60800 JUMPN RDIV ;bignums know about me
60900 JRST ILLNUM
61000 RDIV: IDIV A,TT
61100 PUSH P,B
61200 PUSHJ P,FIX1A
61300 EXCH A,(P)
61400 PUSHJ P,FIX1A
61500 POP P,B
61600 JRST XCONS
61700
61800 REMAINDER:
61900 PUSHJ P,DIVIDE
62000 JRST CDR
62100
62200 FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
62300 ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
62400 FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
62500 ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
62600
62700 GCD: JSP C,OP
62800 JUMPA GCD2 ;bignums know about me
62900 JRST ILLNUM
63000 GCD2: MOVMS A
63100 MOVMS TT
63200 ;euclid's algorithm
63300 GCD3: CAMG A,TT
63400 EXCH A,TT
63500 JUMPE TT,FIX1A
63600 IDIV A,TT
63700 MOVE A,B
63800 JRST GCD3
63900 PAGE
64000 ;general arithmetic op code routine for mixed types
64100
64200 OP: CAIG A,INUMIN
64300 JRST OPA1
64400 SUBI A,INUM0
64500 CAIG B,INUMIN
64600 JRST OPA2
64700 HRREI TT,-INUM0(B)
64800 XCT (C) ;inum op (cannot cause overflow)
64900 FIX1A: ADDI A,INUM0
65000 CAILE A,INUMIN
65100 CAIL A,-1
65200 JRST FIX1B
65300 POPJ P,
65400
65500 OPA1: HRRZ A,(A)
65600 HLRZ T,(A)
65700 HRRZ A,(A)
65800 CAIE T,FIXNUM(S)
65900 JRST OPA6
66000 SKIPA A,(A)
66100 OPA2:
66200 MOVEI T,FIXNUM(S)
66300 CAILE B,INUMIN
66400 JRST OPB2
66500 HRRZ B,(B)
66600 HRRZ TT,(B)
66700 HLRZ B,(B)
66800 CAIE B,FIXNUM(S)
66900 JRST OPA5
67000 SKIPA TT,(TT)
67100 OPB2: HRREI TT,-INUM0(B)
67200 MOVE AR1,A
67300 JFCL 17,.+1
67400 XCT (C) ;fixed pt op
67500 OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
67600 JRST FIX1A
67700
67800 OPA6: CAILE B,INUMIN
67900 JRST OPB7
68000 HRRZ B,(B)
68100 HRRZ TT,(B)
68200 HLRZ B,(B)
68300 CAIE B,FLONUM(S)
68400 JRST OPB3
68500 CAIE T,FLONUM(S)
68600 JRST NUMV3
68700 MOVE A,(A)
68800 MOVE TT,(TT)
68900 OPR: JFCL 17,.+1
69000 XCT 1(C) ;flt pt op
69100 JFCL 10,FLOOV
69200 JRST FLO1A
69300
69400 OPA5:
69500 CAIE B,FLONUM(S)
69600 JRST NUMV3
69700 PUSHJ P,FLOAT
69800 JRST OPR-1
69900
70000 OPB3:
70100 CAIE B,FIXNUM(S)
70200 JRST NUMV3
70300 SKIPA TT,(TT)
70400 OPB7: HRREI TT,-INUM0(B)
70500 MOVEI B,FIXNUM(S)
70600 CAIE T,FLONUM(S)
70700 JRST NUMV3
70800 MOVE A,(A)
70900 EXCH A,TT
71000 PUSHJ P,FLOAT
71100 EXCH A,TT
71200 JRST OPR
00100 SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
00200
00300 %FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
00400 FLATSIZE: HRRZI R,FLAT2
00500 SETZM FLAT1
00600 PUSHJ P,PRINTA
00700 MOVE A,FLAT1#
00800 JRST FIX1A
00900 FLAT2: AOS FLAT1
01000 POPJ P,
01100
01200
01300 %EXPLODE: SKIPA R,.+1
01400 EXPLODE: HRRZI R,EXPL1
01500 MOVSI AR1,AR1
01600 PUSHJ P,PRINTA
01700 JRST SUBS4
01800
01900 EXPL1: PUSH P,B
02000 PUSH P,C
02100 ANDI A,177
02200 CAIL A,"0"
02300 CAILE A,"9"
02400 JRST EXPL2
02500 ADDI A,INUM0-"0"
02600 JRST EXPL4
02700
02800 EXPL2: PUSH P,AR1
02900 PUSH P,TT
03000 PUSH P,T
03100 LSH A,35
03200 MOVE C,SP
03300 PUSH C,A
03400 MOVEI AR1,1
03500 PUSHJ P,INTER0
03600 POP P,T
03700 POP P,TT
03800 POP P,AR1
03900 EXPL4: PUSHJ P,NCONS
04000 HLR B,AR1
04100 HRRM A,(B)
04200 HRLM A,AR1
04300 POP P,C
04400 JRST POPBJ
04500 PAGE
04600 READLIST: TDZA T,T
04700 MAKNAM: MOVNI T,1
04800 MOVEM T,NOINFG
04900 PUSH P,OLDCH
05000 SETZM OLDCH
05100 JUMPE A,NOLIST
05200 HRRM A,MKNAM3
05300 MOVEI A,MKNAM2
05400 PUSHJ P,READ0
05500 HRRZ T,MKNAM3
05600 CAIE T,-1
05700 JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
05800 POP P,OLDCH
05900 POPJ P,
06000
06100 MKNAM2: PUSH P,B
06200 PUSH P,T
06300 PUSH P,TT
06400 HRRZ TT,MKNAM3#
06500 JUMPE TT,MKNAM6
06600 CAIN TT,-1
06700 ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
06800 HRRZ B,(TT)
06900 HRRM B,MKNAM3
07000 HLRZ A,(TT)
07100 CAIGE A,INUMIN
07200 JRST MKNAM5
07300 SUBI A,INUM0-"0"
07400 MKNAM4: POP P,TT
07500 POP P,T
07600 JRST POPBJ
07700
07800 MKNAM5: HLRZ A,(TT)
07900 MOVEI B,PNAME(S)
08000 PUSHJ P,GET
08100 HLRZ A,(A)
08200 LDB A,[POINT 7,(A),6]
08300 JRST MKNAM4
08400
08500 MKNAM6: MOVEI A," "
08600 HLLOS MKNAM3
08700 JRST MKNAM4
08800
08900 ; A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
09000 FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
09100 HRRZ F,A
09200 JRST FALSE
09300 FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
09400 HRRZ B,(A)
09500 MOVEM F,(A)
09600 HRRZ F,A
09700 MOVE A,B
09800 JRST FREELI
00100
00200
00300 APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
00400 JRST UNDTAG
00500 HLRZ T,(A)
00600 CAIE T,-1
00700 JRST GAPP
00800 HRRZ T,(A)
00900 AAGN: JUMPE T,GAPP
01000 HLRZ TT,(T)
01100 HRRZ T,(T)
01200 CAIN TT,FSUBR(S)
01300 JRST [MOVE A,B
01400 HLRZ T,(T)
01500 JRST (T)]
01600 CAIN TT,FEXPR(S)
01700 JRST [ HLRZ T,(T)
01800 HRL T,A
01900 PUSH P,T
02000 MOVE A,B
02100 JRST APPL.2]
02200 CAIN TT,MACRO(S)
02300 JRST [ PUSHJ P,CONS
02400 JRST EVAL]
02500 CAIN TT,EXPR(S)
02600 JRST GAPP
02700 CAIN TT,SUBR(S)
02800 JRST GAPP
02900 CAIE TT,LSUBR(S)
03000 JRST AAGN
03100 GAPP: HRREI T,-2
03200 PUSH P,A
03300 PUSH P,B
03400 JRST APPLY
03500
03600 SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
03700 EV3: HLRZ A,(AR1)
03800 MOVEI B,VALUE(S)
03900 PUSHJ P,GET
04000 JUMPE A,UNDFUN ;function object has no definition
04100 HRRZ A,(A)
04200 REMOTE<
04300 XXX4:
04400 UBDPTR: UNBOUND>
04500 HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
04600 CAME A,B ;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
04700 CAMN A,UBDPTR
04800 JRST UNDFUN
04900 HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
05000 PUSHJ P,CONS
05100 JRST XXEVAL
05200 PAGE
05300 OEVAL: AOJN T,AEVAL
05400 POP P,A
05500 EVAL: PUSH P,SP ;$$SAVE SPDL
05600 PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
05700 POP P,SP ;$$RESTORE SPDL
05800 POPJ P, ;$$AND RETURN TO CALLER
05900
06000 XXEVAL: HRRZM A,AR1
06100 CAILE A,INUMIN
06200 JRST CPOPJ
06300
06400 ;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
06500
06600 PUSH P,B ;$$SAVE WHAT WAS IN B
06700 HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
06800 HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
06900 PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
07000 PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
07100 POP P,B ;$$AND GO OON
07200 HLRZ T,(A) ;;;;;;;;;;;;;
07300
07400
07500 SKIPN ERINT# ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
07600 JRST .+4 ;$$SKIP OVER INTERRUPT FEATURE
07700 SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
07800 PUSHJ P,EPRINT ;$$PRINT OUT WHAT WAS INTERRUPTED
07900 ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
08000
08100 CAIN T,-1
08200 JRST EE1 ;x is atomic
08300 CAILE T,INUMIN
08400 JRST UNDFUN
08500
08600
08700 HLRO TT,(T)
08800 AOJE TT,EE2 ;car (x) is atomic
08900 JRST EXP3
09000
09100 EE1:
09200 EV5: HRRZ AR1,(AR1)
09300 JUMPE AR1,UNBVAR
09400 HLRZ TT,(AR1)
09500 CAIE TT,FLONUM(S)
09600 CAIN TT,FIXNUM(S)
09700 POPJ P,
09800 EVBIG: HRRZ AR1,(AR1) ;bignums know about me
09900 CAIE TT,VALUE(S)
10000 JRST EV5
10100 HLRZ AR1,(AR1)
10200 HRRZ AR1,(AR1)
10300 CAIN AR1,UNBOUND(S)
10400 JRST UNBVAR
10500 MOVEM AR1,A
10600 POPJ P,
10700 PAGE
10800 ; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
10900
11000 ALIST: SKIPE A,-1(P)
11100 PUSHJ P,NUMBERP
11200 MOVEM SP,SPSV
11300 JUMPN A,AEVAL7 ;number
11400 MOVE C,SC2 ;bottom of spec pdl
11500 MOVEM C,AEVAL5#
11600 SETOM AEVAL2
11700 AEVAL8: MOVE C,SP
11800 AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
11900 JRST AEVAL1 ;done
12000 POP C,T ;pointer for next block
12100 JUMPGE T,AEVAL6 ;$$SKIP ANY EVAL BLIP CRAP
12200 AEVAL4: CAMN C,T
12300 JRST AEVAL6 ;thru with block
12400 POP C,AR1
12500 TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
12600 JRST .+3
12700 SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
12800 JRST AEVAL4
12900 MOVSS AR1
13000 PUSH SP,(AR1) ;save value cell
13100 HLRM AR1,(AR1) ;store previous value in value cell
13200 HRLM AR1,(SP) ;save pointer to spec pdl loc
13300 JRST AEVAL4
13400
13500 AEVAL: PUSHJ P,ALIST
13600 POP P,A
13700 MOVEI A,UNBIND
13800 EXCH A,(P)
13900 JRST EVAL
14000 PAGE
14100 AEVAL1: SKIPGE AEVAL2
14200 SKIPN B,-1(P)
14300 JRST ABIND3 ;done with binding
14400
14500 ;alist binding
14600 MOVE A,B
14700 PUSHJ P,REVERSE
14800 SKIPA
14900 ABIND2: MOVE A,B
15000 HRRZ B,(A)
15100 HLRZ A,(A)
15200 HRRZ AR1,(A)
15300 HLRZ A,(A)
15400 PUSHJ P,BIND
15500 JUMPN B,ABIND2
15600 ABIND3: PUSH SP,SPSV
15700 POPJ P,
15800
15900 ;spec pdl binding
16000 AEVAL7: MOVE A,-1(P)
16100 PUSHJ P,NUMVAL
16200 JUMPL A,.+5 ;MAKE SURE IT IS A VALID STACK POINTER
16300 MOVS T,SC2 ;IT'S NOT, MAKE IT VALID
16400 ADD T,A
16500 ADD A,SC2
16600 HRL A,T
16700 CLEARM AEVAL2#
16800 MOVEM A,AEVAL5 ;point to unbind to
16900 JRST AEVAL8
17000
17100 ;AEVAL2: 0 ;0 for number, -1 for a-list
17200 PAGE
17300
17400 EE2: HRRZ T,(T)
17500 JUMPE T,EV3
17600 HLRZ TT,(T)
17700 HRRZ T,(T)
17800 CAIN TT,SUBR(S)
17900 JRST ESB
18000 CAIN TT,LSUBR(S)
18100 JRST EELS
18200 CAIN TT,EXPR(S)
18300 JRST AEXP
18400 CAIN TT,FSUBR(S)
18500 JRST EFS
18600 CAIN TT,MACRO(S)
18700 JRST EFM
18800 CAIE TT,FEXPR(S)
18900 JRST EE2
19000
19100 HLRZ T,(T)
19200 HLL T,(AR1)
19300 PUSH P,T
19400 HRRZ A,(A)
19500 APPL.2: TLO A,400000
19600 PUSH P,A
19700 MOVNI T,1
19800 JRST IAPPLY
19900
20000 AEXP: HLRZ T,(T)
20100 HLL T,(AR1)
20200 EXP3: PUSH P,T
20300 HRRZ A,(AR1)
20400 CILIST: JSP TT,ILIST
20500 EXP2: JRST IAPPLY
20600
20700 EFS: HLRZ T,(T)
20800 HRRZ A,(AR1)
20900 JRST (T)
21000 PAGE
21100 ESB: HRRZ A,(AR1)
21200 UUOS2: HLRZ T,(T)
21300 HLL T,(AR1)
21400 PUSH P,T
21500 JSP TT,ILIST
21600 ESB1: JRST .+NACS+1(T)
21700 POP P,A+4
21800 POP P,A+3
21900 POP P,A+2
22000 POP P,A+1
22100 POPAJ: POP P,A
22200 POPJ P,
22300
22400 EFM: HLRZ T,(T)
22500 CALLF 1,(T)
22600 JRST EVAL
22700 PAGE
22800
22900 APPLY: MOVEI TT,AP2
23000 CAME T,[-3]
23100 JRST PDLARG
23200 MOVEM T,APFNG1#
23300 PUSHJ P,ALIST
23400 MOVE T,APFNG1
23500 JSP TT,PDLARG
23600 PUSH P,[UNBIND]
23700 AP2: PUSH P,A
23800 MOVEI T,0
23900 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
24000 HLRZ C,(B)
24100 PUSH P,C ;push arg
24200 HRRZ B,(B)
24300 SOJA T,AP3
24400
24500 IAP4: JUMPGE D,TOOFEW ;special case for fexprs
24600 AOJN R,TOOFEW
24700 PUSH P,B
24800 MOVE A,SP
24900 PUSHJ P,FIX1A
25000 EXCH A,(P)
25100 MOVE B,A
25200 MOVNI R,2
25300 SOJA T,IAP5
25400
25500 FUNCT: PUSH P,A
25600 MOVE A,SP
25700 PUSHJ P,FIX1A
25800 POP P,B
25900 HLRZ B,(B)
26000 PUSHJ P,XCONS
26100 MOVEI B,FUNARG(S)
26200 JRST XCONS
26300 PAGE
26400 APFNG: SOS T
26500 MOVEM T,APFNG1
26600 JSP TT,PDLARG ;get args and funarg list
26700 HRRZ A,(A)
26800 HRRZ D,(A) ;a-list pointer
26900 HLRZ A,(A) ;function
27000 HRLZ R,APFNG1 ;no. of args
27100 PUSH P,[UNBIND]
27200 JSP TT,ARGP1 ;replace args and fn name
27300 PUSH P,D ;a-list pointer
27400 PUSHJ P,ALIST ;set up spec pdl
27500 POP P,D
27600 AOS T,APFNG1
27700
27800 ;falls through
27900 PAGE
28000 ;falls in
28100
28200 IAPPLY: MOVE C,T ;state of world at entrance
28300 ADDI C,(P) ;t has - number of args on pdl
28400 ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
28500 CAILE B,INUMIN
28600 JRST UNDTAC
28700 HLRZ A,(B)
28800 CAIN A,-1
28900 JRST IAP1 ;fn is atomic
29000 CAIN A,LAMBDA(S)
29100 JRST IAPLMB
29200 CAIN A,FUNARG(S)
29300 JRST APFNG
29400 CAIN A,LABEL(S)
29500 JRST APLBL
29600 PUSH P,T
29700 MOVE A,B
29800 PUSHJ P,EVAL
29900 POP P,T
30000 MOVE C,T
30100 ADDI C,(P)
30200 ILP1B: MOVEM A,(C)
30300 JRST ILP1A
30400
30500 IAPXPR: HLRZ A,(B)
30600 JRST ILP1B
30700 IAP1: HRRZ B,(B)
30800 JUMPE B,IAP2
30900 HLRZ TT,(B)
31000 HRRZ B,(B)
31100 CAIN TT,EXPR(S)
31200 JRST IAPXPR
31300 CAIN TT,LSUBR(S)
31400 JRST IAP6
31500 CAIE TT,SUBR(S)
31600 JRST IAP1
31700 HLRZ B,(B)
31800 MOVEM B,(C)
31900 JRST ESB1
32000 PAGE
32100 IAPLMB: HRRZ B,(B)
32200 HLRZ TT,(B)
32300 MOVEM SP,SPSV
32400 HRRZ B,(B)
32500 HLRZ D,(TT)
32600 CAIN D,-1
32700 JUMPN TT, IAP3
32800 MOVE R,T
32900 IPLMB1: JUMPE T,IPLMB2 ;no more args
33000 JUMPE TT,TOMANY ;too many args supplied
33100 IAP5: HLRZ A,(TT)
33200 MOVEI AR1,1(T)
33300 ADD AR1,P
33400 HLLZ D,(AR1)
33500 HRLM A,(AR1)
33600 HRRZ TT,(TT)
33700 AOJA T,IPLMB1
33800 PAGE
33900
34000
34100 IPLMB2: JUMPN TT,IAP4 ;too few args supplied
34200 JUMPE R,IAP69
34300 IPLMB4: POP P,AR1
34400 HLRZ A,AR1
34500 AOJG R,IPLMB3
34600 PUSHJ P,BIND
34700 JRST IPLMB4
34800 IPLMB3: SKIPE BACTRF
34900 JRST APBK1
35000 APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
35100 PUSH SP,SPSV
35200 MOVE T,B ;$$SETUP FOR IMPLIED PROG
35300 PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
35400 JRST UNBIND
35500
35600 IAP69: POP P,(P)
35700 MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
35800 MOVE T,B ;$$
35900 JRST COND2+1 ;$$INSTEAD OF EVAL
36000
36100 APBK1: HRRI AR1,CPOPJ
36200 TLNE AR1,-1
36300 PUSH P,AR1
36400 JRST APBK2
36500 IAP6: MOVEI TT,CPOPJ
36600 MOVEM TT,(C)
36700 HLRZ B,(B)
36800 JRST (B)
36900
37000 APLBL: MOVEM SP,SPSV
37100 HRRZ B,(B)
37200 HLRZ A,(B)
37300 HRRZ B,(B)
37400 HLRZ AR1,(B)
37500 MOVEM AR1,(C)
37600 PUSHJ P,BIND
37700 MOVEI A,APLBL1
37800 EXCH A,-1(C)
37900 EXCH A,LBLAD#
38000 HRLI A,LBLAD
38100 PUSH SP,A
38200 PUSH SP,SPSV
38300 JRST IAPPLY
38400 APLBL1: PUSH P,LBLAD
38500 JRST SPECSTR
38600
38700 IAP2: HRRZ A,(C)
38800 MOVEI B,VALUE(S)
38900 PUSHJ P,GET
39000 JUMPE A,UNDTAC
39100 HRRZ A,(A)
39200 HRRZ B,(C) ;$$GET ORIGINAL FN NAME
39300 CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
39400 CAIN A,UNBOUND(S)
39500 JRST UNDTAC
39600 JRST ILP1B
39700
39800 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
39900 MOVE A,TT
40000 PUSHJ P,BIND
40100 PUSH P,%ARG
40200 SUBI C,INUM0
40300 HRRM C,%ARG
40400 PUSH SP,SPSV
40500 MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
40600 MOVE T,B ;$$
40700 PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
40800 HRRZ T,%ARG
40900 POP P,%ARG
41000 SUBI T,1-INUM0(P)
41100 HRLI T,-1(T)
41200 ADD P,T
41300 JRST UNBIND
41400
41500 ARG: HRRZ A,@%ARG
41600 POPJ P,
41700
41800 REMOTE<%ARG: XWD A,0>
41900 SETARG: HRRZM B,@%ARG
42000 JRST PROG2
42100 PAGE
42200 BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
42300 CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T
42400 JRST BNDERR ;$$
42500 PUSH P,B
42600 HRRZM A,BIND3#
42700 BIND2:
42800 MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
42900 PUSHJ P,GET ;old binding on s pdl
43000 JUMPE A,BIND1 ;add value cell
43100 PUSH SP,(A)
43200 HRLM A,(SP)
43300
43400 HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
43500 POPBJ: POP P,B
43600 POPJ P,
43700
43800 BIND1:
43900 MOVEI B,UNBOUND(S)
44000
44100 MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
44200 ;$$THIS WAS MOVEI A,0
44300 PUSHJ P,CONS
44400 HRRZ B,@BIND3
44500 PUSHJ P,CONS
44600 MOVEI B,VALUE(S)
44700 PUSHJ P,XCONS
44800 HRRM A,@BIND3
44900 MOVE A,BIND3
45000 JRST BIND2
45100
45200 UBD: CAMG SP,B
45300 POPJ P,
45400
45500
45600 HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
45700 JUMPE TT,.+2 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
45800 JRST PJUBND
45900 SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
46000 JRST UBD ;$$GO BACK AND CHECK
46100
46200 PJUBND: PUSHJ P,UNBIND
46300 JRST UBD
46400
46500 UNBIND:
46600 SPECSTR: MOVE TT,(SP)
46700 CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
46800 POPJ P, ;$$
46900
47000 SUB SP,[XWD 1,1]
47100 JUMPGE TT,UNBIND ;syncronize stack
47200 UNBND1: CAMN SP,TT
47300 POPJ P,
47400 POP SP,T
47500
47600
47700 CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
47800 ;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
47900 JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
48000
48100 MOVSS T
48200
48300 HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
48400
48500 JRST UNBND1
48600
48700
48800 PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
48900 CAIE T,PROGAT+1(S) ;$$CHECK IF IT IS A PROG
49000 JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
49100 MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
49200 ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
49300 POP T,PA4 ;$$RESTORE PA4
49400 POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
49500 PROGU1: POP SP,T ;$$ POP RPDL POINTER
49600 JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
49700
49800
49900
50000 SPECBIND: MOVE TT,SP
50100 SPEC1: LDB R,[POINT 13,(T),ACFLD]
50200 CAILE R,17
50300 JRST SPECX
50400 SKIPE R
50500 MOVE R,(R)
50600 HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
50700 EXCH R,@(T)
50800 HRLI R,@(T)
50900 PUSH SP,R
51000 AOJA T,SPEC1
51100 SPECX: PUSH SP,TT
51200 JRST (T)
51300
51400 ;random special case compiler run time routines
51500
51600 %AMAKE: PUSH P,A ;make alist for fsubr that requires it
51700 MOVE A,SP
51800 PUSHJ P,FIX1A
51900 MOVE B,A
52000 JRST POPAJ
52100
52200 %UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
52300 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
52400 HRRZ R,(P)
52500 PUSHJ P,ERSUB3
52600 JRST ERREND
52700
52800 %LCALL: MOVN A,T ;set up routine for compile lsubr
52900 ADDI A,INUM0
53000 ADDI T,(P)
53100 PUSH P,T
53200 PUSHJ P,(3)
53300 POP P,T
53400 SUBI T,(P)
53500 HRLI T,-1(T)
53600 ADD P,T
53700 POPJ P,
00100 SUBTTL ARRAY SUBROUTINES --- PAGE 14
00200
00300 ARRERR=-1
00400
00500 ARRAY: PUSHJ P,ARRAYS
00600 HRRI AR2A,1(R)
00700 MOVE A,AR2A
00800 PUSH R,[0]
00900 AOBJN A,.-1
01000 ARREND: MOVE A,BPPNR#
01100 MOVEM AR2A,-1(A)
01200 MOVEI A,INUM0+1(R)
01300 MOVEM A,VBPORG(S)
01400 POPJ P,
01500
01600 ARRAYS: PUSH P,A
01700 MOVE A,VBPORG(S)
01800 SUBI A,INUM0
01900 MOVEM A,BPPNR
02000 MOVE A,VBPEND(S)
02100 MOVNI A,-INUM0-2(A)
02200 ADD A,BPPNR ;bporg-bpend+2
02300 HRLM A,BPPNR
02400 POP P,A
02500 HRRZ AR1,(A) ;(cdr l)
02600 HLRZ A,(A) ;(car l)name
02700 HRRZ B,BPPNR
02800 ADDI B,2
02900 MOVEI C,SUBR(S)
03000 PUSHJ P,PUTPROP
03100 HLRZ A,(AR1) ;(cadr l)mode
03200 PUSH P,AR1
03300 PUSHJ P,EVAL ;eval mode
03400 POP P,AR1
03500 MOVEM A,AMODE#
03600 MOVEI C,44
03700 JUMPE A,ARRY1
03800 MOVEI C,-INUM0(A)
03900 CAILE A,INUMIN
04000 JRST ARRY1
04100 MOVEI C,22
04200 HRRZ A,BPPNR
04300 MOVE B,GCMKL
04400 PUSHJ P,CONS
04500 MOVEM A,GCMKL
04600 ARRY1: MOVEM C,BSIZE#
04700 MOVEI A,44
04800 IDIV A,C
04900 MOVEM A,NBYTES#
05000 HRRZ A,(AR1) ;(cddr l)bound pair list
05100 JSP TT,ILIST
05200 AOS R,BPPNR
05300 MOVEI AR1,1 ;ar1 is array size
05400 MOVEI AR2A,0 ;ar2a is cumulative residue
05500 AOJGE T,ARRYS ;single dimension
05600 MOVEI D,A-1
05700 SUB D,T ;d is next ac for array code generation
05800 ARRY2: PUSHJ P,ARRB0
05900 TLC TT,(IMULI)
06000 DPB D,[POINT 4,TT,ACFLD]
06100 PUSH R,TT
06200 CAIN D,A
06300 JRST ARRY3
06400 MOVSI TT,(ADD)
06500 ADDI TT,1(D)
06600 DPB D,[POINT 4,TT,ACFLD]
06700 PUSH R,TT
06800 SOJA D,ARRY2
06900
07000 ARRB0: POP P,TT
07100 EXCH TT,(P)
07200 CAILE TT,INUMIN
07300 JRST ARRB1
07400 HLRZ A,(TT)
07500 HRRZ TT,(TT)
07600 SUBI TT,(A)
07700 ADDI TT,1
07800 JRST ARRB2
07900
08000 ARRB1: MOVEI A,INUM0
08100 SUB TT,A
08200 ARRB2: IMUL A,AR1
08300 IMULB AR1,TT
08400 ADDM A,AR2A
08500 POPJ P,
08600
08700 ARRY3: PUSH R,[ADD A,B]
08800 ARRYS: PUSHJ P,ARRB0
08900 HRRZ TT,BPPNR
09000 MOVEM AR2A,(TT)
09100 HRLI TT,(SUB A,)
09200 PUSH R,TT
09300 PUSH R,[JUMPL A,ARRERR]
09400 MOVE TT,AR1
09500 HRLI TT,(CAIL A,)
09600 PUSH R,TT
09700 PUSH R,[JRST ARRERR]
09800 IDIV AR1,NBYTES ;calc #words in array
09900 SKIPE AR2A ;correct for remainder non-zero
10000 ADDI AR1,1
10100 MOVE TT,NBYTES
10200 SOJE TT,ARRY6
10300 ADDI TT,1
10400 HRLI TT,(IDIVI A,)
10500 PUSH R,TT
10600 MOVN TT,BSIZE
10700 LSH TT,14
10800 HRLI TT,(IMULI B,)
10900 PUSH R,TT
11000 MOVEI TT,44+200
11100 SUB TT,BSIZE
11200 LSH TT,6
11300 ARRY6: ADD TT,BSIZE
11400 LSH TT,6
11500 SKIPE AR2A,AMODE
11600 CAIL AR2A,INUMIN
11700 ADDI TT,40 ;mode not = t
11800 TLC TT,(HRLZI C,)
11900 PUSH R,TT
12000 MOVEI TT,4(R)
12100 HRLI TT,(ADDI C,(A))
12200 PUSH R,TT
12300 PUSH R,[LDB A,C]
12400 HRLZI AR2A,(POPJ P,)
12500 SKIPN TT,AMODE
12600 MOVE AR2A,[JRST FLO1A]
12700 CAIL TT,INUMIN
12800 MOVE AR2A,[JRST FIX1A]
12900 PUSH R,AR2A
13000 MOVS AR2A,AR1
13100 MOVNS AR2A
13200 POPJ P,
13300
13400 PAGE
13500 EXARRAY: PUSH P,A
13600 HLRZ A,(A)
13700 PUSHJ P,GETSYM
13800 JUMPE A,POPAJ
13900 PUSHJ P,NUMVAL
14000 EXCH A,(P)
14100 PUSHJ P,ARRAYS
14200 POP P,A
14300 HRRM A,-2(R)
14400 HRR AR2A,A
14500 JRST ARREND
14600
14700 STORE: PUSH P,A
14800 PUSHJ P,CADR
14900 PUSHJ P,EVAL ;value to store
15000 EXCH A,(P)
15100 HLRZ A,(A)
15200 PUSHJ P,EVAL ;byte pointer returned in c
15300 POP P,A
15400 NSTR: PUSH P,A
15500 TLNE C,40
15600 PUSHJ P,NUMVAL ;numerical array
15700 DPB A,C
15800 POP P,A
15900 POPJ P,
00100 SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
00200
00300 BOOLE: MOVE TT,T
00400 ADDI TT,2(P)
00500 MOVE A,-1(TT)
00600 SUBI A,INUM0
00700 DPB A,[POINT 4,BOOLI,OPFLD-2]
00800 PUSHJ P,BOOLG
00900 MOVE C,A
01000 BOOLL: PUSHJ P,BOOLG
01100 XCT BOOLI
01200 REMOTE<
01300 BOOLI: CLEARB C,A>
01400 JRST BOOLL
01500
01600 BOOLG: CAIL TT,(P)
01700 JRST BOOL1
01800 MOVE A,(TT)
01900 PUSHJ P,NUMVAL
02000 AOJA TT,CPOPJ
02100
02200 BOOL1: HRLI T,-1(T)
02300 ADD P,T
02400 POP P,B
02500 JRST FIX1A
02600
02700 EXAMINE:PUSHJ P,NUMVAL
02800 MOVE A,(A)
02900 JRST FIX1A
03000
03100 DEPOSIT:MOVE C,B
03200 PUSHJ P,NUMVAL
03300 EXCH A,C
03400 PUSHJ P,NUMVAL
03500 MOVEM A,(C)
03600 JRST MAKNUM
03700
03800 LSH: MOVEI C,-INUM0(B)
03900 PUSHJ P,NUMVAL
04000 LSH A,(C)
04100 JRST FIX1A
00100 SUBTTL GARBAGE COLLECTER --- PAGE 16
00200
00300 ;garbage collector
00400
00500 GC: PUSHJ P,AGC
00600 JRST FALSE
00700
00800 AGC: SETOM GCFLG ;SET GCFLAG INCASE OF USER CONTROL-C
00900 MOVEM R,RGC#
01000 GCPK1: PUSH P,PA3
01100 PUSH P,PA4
01200 PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
01300 PUSH P,MKNAM3
01400 PUSH P,GCMKL ;i/o channel input lists and arrays
01500 PUSH P,BIND3
01600 PUSH P,INITF
01700 GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
01800 JRST GCP4
01900 REMOTE<
02000 GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
02100 GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
02200 GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
02300 MOVE A,C3GC
02400 GCP5: BLT A,X ;zero bit tables, .=top of bit tables
02500 JRST GCRET1>
02600 GCRET1: SKIPN GCGAGV
02700 JRST GCP5A
02800 SKIPN F
02900 STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
03000 SKIPN FF
03100 STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
03200
03300 GCP5A: MOVEI TT,1
03400 MOVEI A,0
03500 CALLI A,STIME ;time
03600 MOVNS A
03700 ADDM A,GCTIM#
03800 MOVE C,GCP3# ;.=bottom of reg pdl
03900 GCP6B: MOVE S,P
04000 HLL C,P
04100 MOVEI B,0
04200 GC1: CAMN C,S
04300 POPJ P,
04400 HRRZ A,(C)
04500 GCPI: CAMGE A,GCP# ;.=bottom of bit tables
04600 REMOTE<
04700 GCPP1:
04800 XXX5:FS>
04900 CAMGE A,GCPP1
05000 JRST GCEND
05100 CAML A,GCP1# ;.=bottom of full word space (fws)
05200 JRST GCMFW
05300 MOVE F,(A)
05400 LSHC A,-5
05500 ROT B,5
05600 MOVE AR1,GCBT(B)
05700 TDOE AR1,@GCBTP2 ;bit tab- (fs←-5), .=magic number for sync
05800 JRST GCEND
05900 MOVEM AR1,@GCBTP1 ;bit tab- (fs←-5)
06000 PUSH P,F
06100 HLRZ A,F
06200 JRST GCPI
06300 REMOTE<
06400 GCBTP1: XWD A,0
06500 GCBTP2: XWD A,0
06600 GCMFWS: XWD A,0>
06700
06800 GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
06900 IDIVI AR1,44
07000 MOVNS AR2A
07100 LSH AR2A,36
07200 ADD AR2A,C2GC
07300 DPB TT,AR2A
07400 GCEND: CAMN P,S
07500 AOJA C,GC1
07600 POP P,A
07700 HRRZS A
07800 JRST GCPI
07900 REMOTE<
08000 GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
08100 C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
08200 C3GC: 0> ;(bottom bit table)bottom bit table+1
08300 GCBT: XWD 400000,0
08400 ZZ==1B1
08500 XLIST
08600 REPEAT ↑D31,<ZZ
08700 ZZ==ZZ/2>
08800 LIST
08900 GCP6: HRRZ R,SC2
09000 GCP6C: CAIL R,(SP) ;mark sp
09100 JRST GCP6A
09200 PUSH P,(R)
09300 HRRZ C,P
09400 PUSHJ P,GCP6B
09500 SUB P,[XWD 1,1]
09600 AOJA R,GCP6C
09700
09800 GCP6A: HRRZ R,GCMKL ;mark arrays
09900 GCP6D: JUMPE R,GCSWP
10000 HLRZ A,(R)
10100 MOVE D,(A)
10200 GCP6E: PUSH P,(D)
10300 HRRZ C,P
10400 PUSH P,(D)
10500 MOVSS (P)
10600 PUSHJ P,GCP6B
10700 SUB P,[XWD 2,2]
10800 AOBJN D,GCP6E
10900 HRRZ R,(R)
11000 JRST GCP6D
11100
11200 GFSWPP:
11300 PHASE 0
11400 GFSP1==.
11500 JUMPL S,.+3
11600 HRRZM F,(R)
11700 HRRZ F,R
11800 ROT S,1
11900 AOBJN R,.-4
12000 MOVE S,(D)
12100 HRLI R,-40
12200 AOBJN D,GFSP1
12300
12400 LPROG==.
12500 JRST GFSPR
12600
12700 DEPHASE
12800 ;garbage collector sweep
12900
13000 GCSWP: MOVSI R,GFSWPP
13100 BLT R,LPROG
13200 MOVEI F,NIL ;will become movei f,-1
13300 MOVE D,C3GCS
13400 JRST XXX3
13500 REMOTE<
13600 XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
13700 GCBTL1: HRLI R,X ;-(32-<fs&37>
13800 MOVE S,(D)
13900 GCBTL2: ROT S,X ;fs&37
14000 AOBJN D,GFSP1
14100 JRST GFSPR>
14200 GFSPR: MOVE A,C1GCS
14300 MOVE B,C2GCS
14400 PUSHJ P,GCS0
14500 SKIPN GCGAGV
14600 JRST GCSPI1
14700 MOVE B,F
14800 PUSHJ P,GCPNT
14900 STRTIP [SIXBIT / FREE STG,!/]
15000 MOVE B,FF
15100 PUSHJ P,GCPNT
15200 STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
15300 GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
15400 BLT S,NACS+3 ;reload ac's
15500 SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
15600 AOSN GCFLG ;CHECK FLAG FOR PENDING INTERRUPT
15700 JRST GCEXIT ;NO- SO NORMAL EXIT
15800 POP P,JOBOPC ;INTERRUPT WILL CONTINUE FROM THE GC RETURN
15900 PUSH P,GCFLG ;GC WILL RETURN TO THE INTERRUPT POINT
16000 SETZM GCFLG ;CLEAR GCFLG
16100 GCEXIT: JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
16200 JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
16300 MOVE R,RGC
16400 MOVEI A,0
16500 CALLI A,STIME ;time
16600 ADDM A,GCTIM
16700 MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
16800 ;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
16900
17000 POPJ P,
17100
17200 GCS0: MOVEI FF,0
17300 GCS1: ILDB C,B
17400 JUMPN C,GCS2
17500 HRRZM FF,(A)
17600 HRRZ FF,A
17700 GCS2: AOBJN A,GCS1
17800 POPJ P,
17900
18000 REMOTE<
18100 C1GCS: 0 ;(- length of fws) bottom of fws
18200 C2GCS: XWD 100,0 ;.=bottom of fws bit table
18300 C3GCS: 0 ;-n wds in bt,,bt
18400 >
18500 GCGAG: EXCH A,GCGAGV#
18600 POPJ P,
18700
18800 GCTIME: MOVE A,GCTIM
18900 JRST FIX1A
19000
19100 TIME: MOVEI A,0
19200 CALLI A,STIME
19300 JRST FIX1A
19400
19500 SPEAK: MOVE A,CONSVAL#
19600 JRST FIX1A
19700
19800 GCPNT: MOVEI R,TTYO
19900 MOVEI A,0
20000 JUMPE B,PRINL1
20100 HRRZ B,(B)
20200 AOJA A,.-2
20300
20400 GCING: OUTSTR [ASCIZ /
20500 GARBAGE COLLECTING
20600 /]
20700 POP P,GCFLG ;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
20800 JRST @JOBOPC
00100 SUBTTL GETSYM --- PAGE 17
00200
00300 R50MAK: PUSHJ P,PNAMUK
00400 PUSH C,[0]
00500 HRLI C,700
00600 HRRI C,(SP)
00700 MOVEI B,0
00800 MK3: ILDB A,C
00900 LDB A,R50FLD
01000 CAMGE B,[50*50*50*50*50]
01100 SKIPN A
01200 POPJ P,
01300 IMULI B,50
01400 ADD B,A
01500 JRST MK3
01600
01700 GETSYM: PUSHJ P,R50MAK
01800 TLO B,040000 ;04 for globals
01900 MOVE C,JOBSYM
02000 MK7: CAMN B,(C)
02100 JRST MK10 ;found
02200 AOBJP C,.+2
02300 AOBJN C,MK7
02400 TLC B,140000 ;10 for locals
02500 TLNE B,100000
02600 JRST MK7-1
02700 JRST FALSE
02800
02900 MK10: MOVE A,1(C) ;value
03000 JRST FIX1A
03100
03200 PUTSYM: PUSH P,B
03300 PUSHJ P,R50MAK
03400 MOVE A,B
03500 TLO A,040000 ;make global
03600 SKIPL JOBSYM
03700 AOS JOBSYM ;increment initial symbol table pointer
03800 MOVN B,[XWD 2,2]
03900 ADDB B,JOBSYM
04000 MOVEM A,(B) ;name
04100 POP P,1(B) ;value
04200 JRST FALSE
04300
04400 PATCH: BLOCK 20
04500
00100 SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
00200
00300 ;interface to alvine
00400
00500 IFN ALVINE,<
00600 ED: MOVE 10,EDA
00700 JRST (10)
00800 PUSH P,A
00900 HRRZ A,CORUSE
01000 HRRM A,LST
01100 AOS A
01200 HRRM A,EDA#
01300
01400
01500 HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
01600 AOS ED1# ;$$
01700
01800 MOVSI A,(SIXBIT /ED/)
01900 SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
02000 PUSHJ P,SYSINI
02100 HRLM A,LST
02200 MOVNS A
02300 PUSHJ P,MORCOR
02400 PUSHJ P,SYSINP+1
02500 POP P,A
02600 JRST ED
02700 GRINDEF:PUSH P,A
02800 PUSHJ P,ED
02900 POP P,A
03000 JRST 2(10)>
03100
03200 EXCISE:
03300 IFN ALVINE<
03400 MOVEI A,ED+2
03500 HRRM A,EDA>
03600 MOVE A,JRELO
03700 SETZM LDFLG# ;initial loader symbol table flag
03800 CALLI A,CORE
03900 JRST .+1
04000 JSP R,IOBRST
04100 JRST TRUE
04200
04300 PAGE
04400 ;THIS IS THE NEW IMPROVED VERSION OF SPRINT
04500
04600 ; 0(P) = A
04700 ; -1(P) = B
04800 ; -2(P) = C
04900 ; -3(P) = M
05000 ; -4(P) = N
05100 ; -5(P) = X
05200
05300
05400 SPRINT: SUBI B,INUM0
05500 SPRNT2: PUSH P,A
05600 PUSH P,B
05700 SETZM M#
05800 SETZM CSW#
05900 MOVEM P,STP#
06000 MOVEI B,0
06100 PUSHJ P,DEPTH
06200 SKIPN B,M
06300 JRST .+6
06400 MOVE A,LINL
06500 SUB A,B
06600 SUB A,B
06700 IDIV A,B
06800 CAILE A,14
06900 MOVEI A,14
07000 MOVEM A,CUT#
07100 MOVE A,0(P)
07200 IDIV A,LINL
07300 CAIG B,0
07400 ADD B,LINL
07500 MOVEM B,0(P)
07600 MOVEI C,0
07700 JRST .+3
07800
07900 ISPRIN: PUSH P,A
08000 PUSH P,B
08100 PUSH P,C
08200 PUSH P,[0]
08300 PUSH P,[0]
08400 PUSH P,[0]
08500 MOVE A,B
08600 SUB B,LINL
08700 JUMPLE B,.+3
08800 MOVE A,B
08900 MOVEM A,-4(P)
09000 PUSHJ P,POS
09100 MOVE A,-5(P)
09200 PUSHJ P,PATOM
09300 JUMPE A,.+4
09400 SPRN1: MOVE A,-5(P)
09500 PUSHJ P,PRIN1
09600 JRST SPRN22
09700 MOVE B,LINL
09800 SUB B,-4(P)
09900 ADDI B,1
10000 MOVEM B,0(P)
10100 SUB B,-3(P)
10200 MOVE A,-5(P)
10300 PUSHJ P,FLATLE
10400 JUMPN A,SPRN1
10500 MOVEI A,50
10600 PUSHJ P,TYO
10700 AOS -4(P)
10800 SOS 0(P)
10900 HRRZ A,@-5(P)
11000 PUSHJ P,PATOM
11100 JUMPN A,SPRN13
11200 HLRZ A,@-5(P)
11300 CAIN A,LAMBDA(S)
11400 JRST LAM
11500 CAIN A,PROGAT+1(S)
11600 JRST PRG
11700 PUSHJ P,PATOM
11800 JUMPE A,SPRN3
11900 HLRZ A,@-5(P)
12000 PUSHJ P,PRIN1
12100 MOVE A,0(P)
12200 SUB A,CHCT
12300 MOVEM A,-1(P)
12400 CAIG A,24
12500 JRST SPRN4
12600 JRST SPRN12+4
12700 SPRN3: MOVE B,0(P)
12800 CAILE B,20
12900 MOVEI B,20
13000 HLRZ A,@-5(P)
13100 PUSHJ P,FLATLE
13200 JUMPE A,SPRN12
13300 MOVEM A,-1(P)
13400 SPRN4: HRRZ A,@-5(P)
13500 MOVEM A,-2(P)
13600 HRRZ A,0(A)
13700 PUSHJ P,PATOM
13800 JUMPN A,SPRN8
13900 MOVE B,-1(P)
14000 CAMG B,CUT
14100 JRST SPRN2
14200 SKIPE CSW
14300 JRST SPRN8
14400 MOVE A,0(P)
14500 SUB A,B
14600 SUBI A,1
14700 MOVEM A,-1(P)
14800 JRST SPRN5
14900 SPRN2: HLRZ A,@-5(P)
15000 PUSHJ P,PATOM
15100 JUMPN A,.+3
15200 HLRZ A,@-5(P)
15300 PUSHJ P,PRIN1
15400 HRRZ A,@-5(P)
15500 MOVEM A,-5(P)
15600 MOVE A,-4(P)
15700 ADD A,-1(P)
15800 ADDI A,1
15900 MOVEM A,-4(P)
16000 JRST SPRN12
16100 SPRN5: MOVE B,-1(P)
16200 HLRZ A,@-2(P)
16300 PUSHJ P,FLATLE
16400 JUMPE A,SPRN8
16500 HRRZ A,@-2(P)
16600 MOVEM A,-2(P)
16700 HRRZ A,0(A)
16800 PUSHJ P,PATOM
16900 JUMPE A,SPRN5
17000 HRRZ B,@-2(P)
17100 JUMPN B,.+3
17200 MOVE B,-1(P)
17300 SOJA B,SPRN7
17400 HRRZ A,@-2(P)
17500 PUSHJ P,FLATSI
17600 SUBI A,INUM0-4
17700 SUB A,-1(P)
17800 MOVN B,A
17900 SPRN7: SUB B,-3(P)
18000 HLRZ A,@-2(P)
18100 PUSHJ P,FLATLE
18200 JUMPN A,SPRN18
18300 SPRN8: HLRZ A,@-5(P)
18400 PUSHJ P,PATOM
18500 JUMPN A,.+3
18600 SPRN9: HLRZ A,@-5(P)
18700 PUSHJ P,PRIN1
18800 HRRZ A,@-5(P)
18900 MOVEM A,-5(P)
19000 CAMN A,-2(P)
19100 JRST SPRN11
19200 MOVE A,-4(P)
19300 PUSHJ P,POS
19400 JRST SPRN9
19500 SPRN11: HRRZ A,@-5(P)
19600 PUSHJ P,PATOM
19700 JUMPN A,SPRN13
19800 SPRN12: MOVEI C,0
19900 MOVE B,-4(P)
20000 HLRZ A,@-5(P)
20100 PUSHJ P,ISPRIN
20200 HRRZ A,@-5(P)
20300 MOVEM A,-5(P)
20400 JRST SPRN11
20500 SPRN13: HRRZ A,@-5(P)
20600 JUMPE A,.+4
20700 PUSHJ P,FLATSI
20800 SUBI A,INUM0-3
20900 ADDM A,-3(P)
21000 AOS -3(P)
21100 MOVE C,-3(P)
21200 MOVE B,-4(P)
21300 HLRZ A,@-5(P)
21400 PUSHJ P,ISPRIN
21500 SPRN16: HRRZ A,@-5(P)
21600 JUMPE A,SPRN17
21700 MOVEI A,40
21800 PUSHJ P,TYO
21900 MOVEI A,56
22000 PUSHJ P,TYO
22100 MOVEI A,40
22200 PUSHJ P,TYO
22300 HRRZ A,@-5(P)
22400 PUSHJ P,PRIN1
22500 SPRN17: MOVEI A,51
22600 PUSHJ P,TYO
22700 JRST SPRN22
22800 SPRN18: HLRZ A,@-5(P)
22900 PUSHJ P,PATOM
23000 JUMPN A,.+3
23100 HLRZ A,@-5(P)
23200 PUSHJ P,PRIN1
23300 MOVEI A,40
23400 PUSHJ P,TYO
23500 HRRZ A,@-5(P)
23600 MOVEM A,-5(P)
23700 MOVE A,LINL
23800 SUB A,CHCT
23900 ADDI A,1
24000 MOVEM A,-4(P)
24100 HRRZ A,@-5(P)
24200 PUSHJ P,PATOM
24300 JUMPN A,SPRN21
24400 SPRN19: HLRZ A,@-5(P)
24500 PUSHJ P,PRIN1
24600 HRRZ A,@-5(P)
24700 MOVEM A,-5(P)
24800 HRRZ A,0(A)
24900 PUSHJ P,PATOM
25000 JUMPN A,.+4
25100 MOVE A,-4(P)
25200 PUSHJ P,POS
25300 JRST SPRN19
25400 MOVE A,-4(P)
25500 PUSHJ P,POS
25600 SPRN21: HLRZ A,@-5(P)
25700 PUSHJ P,PRIN1
25800 JRST SPRN16
25900 LAM: PUSHJ P,PRIN1
26000 HRRZ A,@-5(P)
26100 MOVEM A,-5(P)
26200 MOVE B,-4(P)
26300 MOVEM B,-1(P)
26400 HLRZ A,0(A)
26500 PUSHJ P,PATOM
26600 MOVEI B,6
26700 CAIE A,NIL
26800 ADDI B,1
26900 ADDM B,-4(P)
27000 HRRZ A,@-5(P)
27100 PUSHJ P,PATOM
27200 JUMPN A,SPRN13
27300 MOVEI C,0
27400 MOVE B,-4(P)
27500 HLRZ A,@-5(P)
27600 PUSHJ P,ISPRIN
27700 MOVE B,-1(P)
27800 MOVEM B,-4(P)
27900 JRST SPRN12+4
28000 PRG: PUSHJ P,PRIN1
28100 HRRZ A,@-5(P)
28200 MOVEM A,-5(P)
28300 MOVE A,-4(P)
28400 MOVEM A,-1(P)
28500 MOVEI A,5
28600 ADDM A,-4(P)
28700 HRRZ A,@-5(P)
28800 PUSHJ P,PATOM
28900 JUMPN A,SPRN13
29000 MOVEI C,0
29100 MOVE B,-4(P)
29200 HLRZ A,@-5(P)
29300 PUSHJ P,ISPRIN
29400 MOVE A,0(P)
29500 SUBI A,5
29600 MOVEM A,-2(P)
29700 PRG1: HRRZ A,@-5(P)
29800 MOVEM A,-5(P)
29900 HRRZ A,0(A)
30000 PUSHJ P,PATOM
30100 JUMPN A,PRG3
30200 HLRZ A,@-5(P)
30300 PUSHJ P,PATOM
30400 JUMPE A,PRG2
30500 MOVE A,-1(P)
30600 PUSHJ P,POS
30700 HLRZ A,@-5(P)
30800 PUSHJ P,PRIN1
30900 JRST PRG1
31000 PRG2: MOVE A,CHCT
31100 CAMG A,-2(P)
31200 PUSHJ P,TERPRI
31300 MOVEI C,0
31400 MOVE B,-4(P)
31500 HLRZ A,@-5(P)
31600 PUSHJ P,ISPRIN
31700 JRST PRG1
31800 PRG3: HLRZ A,@-5(P)
31900 PUSHJ P,PATOM
32000 JUMPE A,SPRN13
32100 MOVE B,-1(P)
32200 MOVEM B,-4(P)
32300 JRST SPRN13
32400 SPRN22: MOVEI A,NIL
32500 SUB P,[XWD 6,6]
32600 POPJ P,
32700
32800 POS: PUSH P,A
32900 PUSH P,[0]
33000 MOVE A,LINL
33100 SUB A,CHCT
33200 ADDI A,1
33300 PUSH P,A
33400 CAMN A,-2(P)
33500 JRST POS4
33600 CAMG A,-2(P)
33700 JRST .+4
33800 PUSHJ P,TERPRI
33900 MOVEI A,1
34000 MOVEM A,0(P)
34100 SUBI A,1
34200 LSH A,-3
34300 ADDI A,1
34400 LSH A,3
34500 ADDI A,1
34600 MOVEM A,-1(P)
34700 CAMLE A,-2(P)
34800 JRST POS3
34900 POS2: MOVEI A,11
35000 PUSHJ P,TYO
35100 MOVE A,-1(P)
35200 MOVEM A,0(P)
35300 ADDI A,10
35400 JRST POS2-3
35500 POS3: AOS A,0(P)
35600 CAMLE A,-2(P)
35700 JRST POS4
35800 MOVEI A,40
35900 PUSHJ P,TYO
36000 JRST POS3
36100 POS4: SUB P,[XWD 3,3]
36200 POPJ P,
36300
36400 FLATLE: JUMPLE B,ABORT+1
36500 SETZM M
36600 MOVEM B,N#
36700 MOVEM P,STP
36800 SCAN: PUSH P,A
36900 PUSHJ P,PATOM
37000 JUMPN A,EXIT1-6
37100 NA: AOS A,M
37200 CAMLE A,N
37300 JRST ABORT
37400 HLRZ A,@0(P)
37500 PUSHJ P,SCAN
37600 HRRZ A,@0(P)
37700 MOVEM A,0(P)
37800 JUMPN A,.+3
37900 AOS A,M
38000 JRST EXIT1-2
38100 MOVE A,0(P)
38200 PUSHJ P,PATOM
38300 JUMPE A,NA
38400 MOVEI A,4
38500 ADDB A,M
38600 CAMLE A,N
38700 JRST ABORT
38800 MOVE A,0(P)
38900 PUSHJ P,FLATSI
39000 SUBI A,INUM0
39100 ADDB A,M
39200 CAMLE A,N
39300 JRST ABORT
39400 EXIT1: SUB P,[XWD 1,1]
39500 POPJ P,
39600 ABORT: MOVE P,STP
39700 MOVEI A,NIL
39800 POPJ P,
39900
40000 DEPTH: PUSH P,A
40100 PUSH P,B
40200 PUSHJ P,PATOM
40300 JUMPN A,D2
40400 AOS A,0(P)
40500 CAMLE A,LINL
40600 JRST OUT+1
40700 CAMLE A,M
40800 MOVEM A,M
40900 MOVE A,-1(P)
41000 PUSH P,A
41100 PUSH P,[0]
41200 D1: HLRZ A,@-3(P)
41300 MOVE B,-2(P)
41400 PUSHJ P,DEPTH
41500 HRRZ A,@-3(P)
41600 MOVEM A,-3(P)
41700 MOVE B,-1(P)
41800 SETCMB C,0(P)
41900 JUMPN C,.+3
42000 HRRZ B,0(B)
42100 MOVEM B,-1(P)
42200 CAMN A,B
42300 JRST OUT
42400 PUSHJ P,PATOM
42500 JUMPE A,D1
42600 SUB P,[XWD 2,2]
42700 D2: SUB P,[XWD 2,2]
42800 POPJ P,
42900 OUT: SETOM CSW
43000 MOVE P,STP
43100 JRST @1(P)
43200 ;
43300 ;
43400 ;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
43500 ;
43600 .TAB: PUSHJ P,NUMVAL
43700 PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
43800 JRST FALSE
43900 PAGE
44000 ; lisp loader interface
44100 ; REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
44200 LOAD: AOS B,CORUSE
44300 MOVEM B,OLDCU#
44400 MOVEM A,LDPAR#
44500 JUMPE A,LOAD2
44600 MOVE B,VBPORG(S)
44700 SUBI B,INUM0
44800 LOAD2: MOVEM B,RVAL# ;final destination of loaded code
44900 MOVSI A,(SIXBIT /LOD/)
45000 SETZ D,
45100 PUSHJ P,SYSINI
45200 SUBI A,150 ;extra room for locations 0 to 137 and slop
45300 PUSH P,A
45400 MOVNS A ;length(loader)
45500 HRRZM A,LODSIZ#
45600 PUSHJ P,MORCOR ;expand core for loader
45700 MOVEM A,LOWLSP# ;location of blt'ed low lisp
45800 MOVN B,(P) ;length(loader)
45900 ADD B,A
46000 MOVEM B,HVAL# ;temporary destination of loaded code
46100 HRLI A,0
46200 MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
46300 BLT A,(B) ;blt up low lisp
46400 HLL A,NAME+3(D) ;-length(loader)
46500 HRRI A,137-1
46600 PUSHJ P,SYSINP
46700 SKIPE LDFLG(D)
46800 JRST LOAD3
46900 SETOM LDFLG(D)
47000 MOVSI A,(SIXBIT /SYM/)
47100 PUSHJ P,SYSINI
47200 MOVNS A ;length symbols
47300 PUSHJ P,MORCOR ;expand core for symbols
47400 SKIPGE B,JOBSYM
47500 SOS B ;if no symbol table, use original jobsym
47600 HLRZ A,NAME+3(D) ;-length(symbols)
47700 ADDB A,B
47800 HLL A,NAME+3(D) ;symbol table iowd
47900 PUSHJ P,SYSINP
48000 HRRM B,JOBSYM
48100 HLLZ A,NAME+3(D)
48200 ADDM A,JOBSYM
48300 SKIPA
48400 LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
48500 MOVE 3,HVAL(D) ;h
48600 MOVE 5,RVAL(D) ;r
48700 MOVE 2,3
48800 SUB 2,5 ;x=h-r
48900 HRLI 5,12 ;(w)
49000 HRLI 2,11 ;(v)
49100 SETZB 1,4
49200 JSP 0,140 ;call the loader
49300 MOVEM 5,RLAST#(D) ;last location loaded(in final area)
49400 MOVE T,OLDCU(D)
49500 MOVE A,JOBSYM
49600 MOVEM A,JOBSYM(T)
49700 MOVE A,JOBREL
49800 MOVEM A,JOBREL(T) ;update jobrel
49900 HRLZ 0,LOWLSP(D)
50000 SOS LODSIZ(D)
50100 AOBJN 0,.+1
50200 BLT 0,@LODSIZ(D) ;blt down low lisp
50300 MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
50400 MOVE B,RLAST
50500 MOVE A,RVAL
50600 HRL A,HVAL
50700 SKIPE LDPAR
50800 JRST BINLD
50900 MOVE C,RLAST ;new coruse
51000 LDRET2: BLT A,(B) ;blt down loaded code
51100 HRRZM C,CORUSE ;top of code loaded
51200 MOVEI B,1
51300 ANDCAM B,JOBSYM
51400 SUB C,JOBSYM ;length of free core
51500 ORCMI C,776000
51600 AOJGE C,START ;no contraction
51700 ADD C,JOBREL ;new top of core
51800 MOVE B,C
51900 PUSHJ P,MOVDWN
52000 HRLM C,JOBSA
52100 CALLI C,CORE ;contract core
52200 JRST .+1
52300 JRST START
52400
52500 BINLD: MOVEI C,INUM0(B)
52600 CAML C,VBPEND(S)
52700 JRST [ SETOM BPSFLG ;bps exceeded
52800 JRST START]
52900 MOVEM C,VBPORG(S) ;updat bporg
53000 SOS C,OLDCU ;old top of core
53100 JRST LDRET2
53200
53300 SYSINI: MOVEM A,NAME+1(D)
53400 IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
53500 MOVEM A,NAME+3(D)>
53600 IFE SYSPRG,< SETZM NAME+3(D)>
53700 INIT 17
53800 SYSDEV
53900 0
54000 JRST AIN.4+1
54100 LOOKUP NAME(D)
54200 JRST AIN.7+1
54300 MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
54400 ADD A,D
54500 MOVEM A,INLOW(D)
54600 INPUT INLOW(D) ;INPUT SIZE OF FILE
54700 REMOTE<
54800 INLOW: IOWD 1,NAME+3
54900 0>
55000 HLRO A,NAME+3(D)
55100 POPJ P,
55200
55300 REMOTE<
55400 NAME: SYSNAM
55500 0
55600 0
55700 0>
55800
55900 SYSINP: MOVEM A,LST(D)
56000 INPUT LST(D)
56100 STATZ 740000
56200 ERR1 AIN.8
56300 RELEASE
56400 POPJ P,
56500
56600 REMOTE<
56700 LST: 0
56800 0>
56900 PAGE
57000 MOVDWN: HLRZ A,JOBSYM
57100 JUMPE A,MOVS1
57200 ADDI A,1(B)
57300 HRL A,JOBSYM
57400 HRRM A,JOBSYM
57500 BLT A,(B) ;downward blt
57600 POPJ P,
57700
57800 MOVSYM: MOVE B,JOBREL
57900 HRLM B,JOBSA
58000 HLRE A,JOBSYM
58100 JUMPE A,MOVS1
58200 ADDI B,1(A) ;new bottom of symbol table
58300 MOVNI A,1(A)
58400 ADD A,JOBSYM ;last loc of old symbol table
58500 HRRM B,JOBSYM
58600 PUSH P,C
58700 MOVE B,JOBREL ;last loc of new symbol table
58800 MOVE C,(A) ;simulated upward blt
58900 MOVEM C,(B)
59000 SUBI B,1
59100 ADDI A,-1 ;lf+1,rt-1
59200 JUMPL A,.-4
59300 POP P,C
59400 POPJ P,
59500
59600 MOVS1: HRRZM B,JOBSYM
59700 POPJ P,
59800
59900 ;enter with size needed in a
60000 ;exit with pointer in a to core
60100
60200 MORCOR: PUSH P,B
60300 HRRZ B,JOBSYM
60400 SUB B,CORUSE(D)
60500 SUBM A,B
60600 JUMPL B,EXPND2
60700 ADD B,JOBREL ;new core size
60800 CALLI B,CORE ;expand core
60900 ERR1 [SIXBIT /CANT EXPAND CORE !/]
61000 PUSH P,A
61100 PUSHJ P,MOVSYM
61200 POP P,A
61300 EXPND2: MOVE B,CORUSE(D)
61400 ADDM A,CORUSE(D)
61500 MOVE A,B
61600 POP P,B
61700 POPJ P,
61800 PAGE
61900 SUBTTL HIGH SEGMENT FUNCTIONS
62000
62100 REMOTE<VHGHORG:BHORG>
62200 HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
62300 PUSHJ P,NUMVAL
62400 JUMPLE A,FALSE
62500 CLEARB C,WRTSTS
62600 CALLI C,SETUWP
62700 UWPERR: ERR1 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
62800 MOVE B,VHGHORG
62900 ADD B,A
63000 HRRZ C,JOBHRL
63100 CAMG B,C
63200 JRST TRUE
63300 IFE STANSW,< HRLZ A,B
63400 CALLI A,CORE >
63410 IFN STANSW,< HRRZ A,B
63420 CALLI A,400015>
63500 ERR1 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
63600 JRST TRUE
63700 NOWRT: MOVEI A,1
63800 MOVEM A,WRTSTS
63900 CALLI A,SETUWP
64000 JRST UWPERR
64100 JRST TRUE
64200
64300 HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
64400 PUSHJ P,NUMVAL
64500 PUSH P,A
64600 MOVE A,VHGHORG
64700 MOVEI B,FIXNUM(S)
64800 PUSHJ P,MAKNUM
64900 POP P,B
65000 SKIPE B
65100 MOVEM B,VHGHORG
65200 POPJ P,
65300
65400 HGHEND: HRRZ A,JOBHRL ;GET VALUE OF END OF HIGH SEG.
65500 MOVEI B,FIXNUM(S)
65600 JRST MAKNUM
65700
65800 ;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
65900 SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
66000 PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
66100 MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
66200 MOVE A,DEV ;GET THE DEVICE AND SAVE IT
66300 MOVEM A,HGHDAT
66400 MOVE A,PPN ;GET THE PPN AND SAVE IT
66500 MOVEM A,HGHDAT+4
66600 JRST FALSE ;RETURN NIL
66700
66800 REMOTE<WRTSTS: 1>
66900 PAGE
67000 SUBTTL REALLOC CODE --- PAGE 19
67100
67200 STRT:
67300 INALLC: HRRZ A,JOBREL ;SEE IF CORE WAS EXPANDED
67400 CAMN A,JRELO# ;OR NOT
67500 JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
67600 CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
67700 JRST 4,0 ;YES - BITCH
67800 MOVEM A,JRELO# ;SAVE NEW CORE BOUND
67900 HRLM A,JOBSA
68000 IFN ALVINE,<
68100 MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
68200 HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
68300 INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
68400 OUTSTR [ASCIZ /
68500 ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
68600 INCHRW C ;THE ALLOCATION INCREMENTS
68700 CAIGE C,"O"
68800 SETOM NOALIN# ;SET FLAG SO NO INPUT IS DONE LATER
68900 SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
69000 MOVEM A,OSFWS#
69100
69200 SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
69300 OUTSTR [ASCIZ /
69400 FULL WORD SP. = /]
69500 JSP R,ALLNUM
69600 JUMPN A,.+3
69700 SKIPE INITFW#
69800 ADDI A,440 ;INITIAL ALLOCATION FOR FWS
69900
70000 ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
70100
70200 MOVE A,FSO# ;SAVE OLD FS ORIGIN
70300 MOVEM A,OFSO# ;FOR RELOCATION
70400
70500
70600 SKIPN NOALIN ;SKIP IF USER DONE
70700 OUTSTR [ASCIZ /
70800 BIN. PROG. SP. = /]
70900 JSP R,ALLNUM
71000 ADDM A,SBPS#
71100 MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
71200 ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
71300
71400
71500
71600 SKIPN NOALIN ;SKIPIF USER DONE
71700 OUTSTR [ASCIZ /
71800 REG. PDL. = /]
71900 JSP R,ALLNUM
72000 JUMPN A,.+3
72100 SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
72200 ADDI A,1000
72300 ADDM A,SRPDL#
72400 MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
72500
72600
72700 SKIPN NOALIN ;SKIP IF USER DONE
72800 OUTSTR [ASCIZ /
72900 SPEC. PDL. = /]
73000 JSP R,ALLNUM
73100 JUMPN A,.+3
73200 SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
73300 ADDI A,1000
73400 ADDM A,SSPDL#
73500 MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
73600 IFN HASH,<
73700 SKIPN INITFW
73800 SETOM NOALIN
73900 SKIPN NOALIN
74000 OUTSTR [ASCIZ /
74100 HASH = /]
74200 JSP R,ALLNUM
74300 CAIG A,BCKETS
74400 JRST OCR
74500 HRRM A,INT1
74600 MOVNS A
74700 HRRM A,RH4
74800 SETOM HASHFG>
74900 OCR: OUTSTR [ASCIZ /
75000 /]
75100 MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
75200 SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
75300
75400 SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
75500 SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
75600 SUB A,SBT# ;AND ASSOCIATED BIT TABLE
75700 SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
75800 SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
75900 SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
76000
76100 MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
76200 IDIVI F,44
76300 ADDI F,1
76400 SUB A,F ;AND TAKE IT OFF TOTAL
76500 MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
76600 JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
76700 OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
76800 /] ; IF SO THEN RETRY
76900 MOVE A,OSFWS
77000 MOVEM A,SFWS ;RESTORE SIZE OF FWS
77100 MOVN A,FSMOVE
77200 ADDM A,SBPS ;RESET SIZE OF BPS
77300 ADDM A,FSO ;AND FS ORGIN
77400 ADDM AR1,SRPDL ;RESET STACKS
77500 ADDM AR2A,SSPDL
77600 JRST INAGN
77700
77800 ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
77900 ACHLOC: ASH B,-4 ;1/16 TO FWS
78000 ADDM B,SFWS
78100 SUB A,B ;TAKE IT OFF REMAINING CORE
78200 SKIPE INITFW
78300 SETZ B,
78400 ASH B,-4 ;1/64 TO PDLS
78500 ADDM B,SSPDL
78600 SUB A,B
78700 ADDM B,SRPDL
78800 SUB A,B ;AND TAKE IT OFF REMAINING CORE
78900
79000 MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
79100 IDIVI T,44
79200 ADDI T,1
79300 ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
79400 MOVEM T,SBTF
79500 SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
79600
79700 ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
79800 ADD A,SBT ;AND ASSOCIATED BT
79900 ;GIVING NEW SPACE AVAILABLE FOR
80000 ;FS AND BT
80100 MOVE TT,A
80200 IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
80300
80400 ADDI TT,1
80500 MOVEM TT,SBT
80600
80700 SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
80800 MOVEM A,SFS ;GIVING AVAILABLE SFS
80900
81000
81100 ;SET UP REGISTERS FOR GC ETC. SETUP
81200
81300 MOVE A,SFWS ;A ← SFWS
81400 MOVEI B,FS
81500 ADD B,SFS
81600 ADD B,SBPS ;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
81700 MOVE C,SRPDL ;C ← SRPDL
81800 MOVE F,OSFWS ;F ← OLD SIZE OF FWS
81900
82000
82100
82200
82300 HRRM B,GCP1 ;GCP1 ← NFWSO
82400 MOVN SP,B ;-NEW BOTTOM OF FWS
82500
82600 HRRM SP,GCMFWS
82700 HRLZM A,C1GCS
82800 MOVNS C1GCS ;-NEW LENGTH OF FWS
82900 HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
83000
83100 ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
83200
83300
83400 MOVE SP,FSO ;SP ← NEW ORIGIN OF FS
83500
83600 LSH SP,-5
83700 SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
83800 HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
83900 HRRM SP,GCBTP2
84000
84100 HRLM B,C3GC ;BOTTOM OF BIT TABLES
84200 HRRM B,GCP2
84300 HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
84400
84500 MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
84600 HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
84700 HRRM B,C3GCS
84800 MOVE SP,FSO
84900 ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
85000 HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
85100 SUBI SP,40
85200 HRRM SP,GCBTL1
85300
85400 ADDI B,1 ;B ← B + 1
85500 HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
85600 ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
85700 HRRM B,C2GCS ;BEFORE USE
85800
85900 ADDI B,1 ;B ← B + 1
86000 HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
86100 ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
86200
86300 HRRM B,GCP5 ;TOP OF BIT TABLES
86400 ADDI B,1 ;BOTTOM OF REG PDL
86500
86600 HRRZ A,RHX2 ;GET OBLIST POINTER
86700 ADD A,FSMOVE ;INCREMENT TO
86800 ;ACCOUNT FOR MOVE OF FS
86900 MOVEM A,(B)
87000 HRRM B,GCP3 ;ROOM FOR ACS DURING GC
87100 ADDI B,1 ;B ← B + 1
87200 HRRM B,GCSP1
87300 HRRM B,GCP4 ;ROOM FOR ACS
87400 ADDI B,10 ;B ← B + 10
87500 HRRM B,GCP41 ;TOP OF AC AREA
87600 ADDI B,1 ;B ← B + 1
87700 HRRM B,C2 ;SET UP RPDL POINTER
87800 MOVNI A,-20(C) ;A ← - (C -20) = -(SRPDL - 20)
87900 HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
88000 ;TAKING INTO ACCOUNT THE AC AREA
88100
88200 HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
88300
88400 MOVN B,SSPDL
88500 ADD A,B
88600 HRL A,B
88700
88800 MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
88900 MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
89000 ADDI A,INUM0
89100 HRRZM A,SPNM#
89200 SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
89300
89400
89500
89600
89700 ;RELOCATE THE FULL WORD SPACE
89800 ;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
89900 ;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
90000 ;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
90100
90200 MOVSI B,F
90300 HRR B,GCP1
90400 MOVE C,FWSO#
90500 HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
90600 ;OF END OF OLD FS (USED LATER)
90700 HRLI C,F
90800 MOVE A,@C ;GET WORD FROM END OF OLD FWS
90900 MOVEM A,@B ;AND MOVE TO END OF NEW FWS
91000 SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
91100 ;END OF FWS RELOCATION
91200
91300 MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
91400 HRRZ F,AR2A
91500 ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
91600 ;END OF OLD FS IN NEW FS
91700
91800
91900
92000 HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
92100 SUB AR1,FWSO
92200
92300
92400
92500 ;RELOCATE FS - ALSO RELOCATE ALL
92600 ;POINTERS TO FS AND TO FWS
92700
92800 REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
92900 JSP R,REL4
93000 HRLM A,(F) ;MOVE CAR TO NEW POSITION
93100 HRRZ A,(AR2A) ;GET CDR PTR
93200 JSP R,REL4 ;CHECK FOR FS RELOCATE
93300 HRRM A,(F)
93400 SUBI F,1 ;F ← F -1
93500 CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
93600 SOJA AR2A,REL1 ;NO - GO LOOP
93700 HRRZ A,GCMKL ;RELOCATE ARRAYS
93800 JSP R,REL4
93900 HRRZ D,A
94000 MOVEM D,GCMKL
94100 REL5: HLRZ AR2A,(D)
94200 MOVE AR2A,(AR2A)
94300 REL6: HLRZ A,(AR2A)
94400 JSP R,REL4
94500 HRLM A,(AR2A)
94600 HRRZ A,(AR2A)
94700 JSP R,REL4
94800 HRRM A,(AR2A)
94900 AOBJN AR2A,REL6
95000 HRRZ D,(D)
95100 JUMPN D,REL5
95200 SETZM BIND3 ;JUST IN CASE
95300 SKIPE INITF ;DON'T FORGET THE INITFN
95400 ADDM FF,INITF
95500 SKIPE NOUUOF ;RELOCATE FLAGS
95600 ADDM FF,NOUUOF
95700 SKIPE BACTRF
95800 ADDM FF,BACTRF
95900 SKIPE GCGAGV
96000 ADDM FF,GCGAGV
96100 SKIPE RSTSW
96200 ADDM FF,RSTSW
96300 JRST RELFOO
96400
96500 REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
96600 CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
96700 JRST (R)
96800 CAMGE A,FWSO ;SEE IF IN FWS
96900 JRST .+3
97000 ADD A,AR1 ;RELOCATE FWS POINTER
97100 JRST (R)
97200 ADD A,FF ;RELOCATE FS POINTER
97300 JRST (R)
97400
97500
97600
97700
97800
97900 RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
98000 MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
98100 MOVE A,FSMOVE ;NOW IS THE TIME FOR ALL GOOD MEN TO
98200 ADDM A,VBPEND(S) ;SET BPEND
98300 ADDM A,XXX1 ;AND SOMEOTHER CRAP
98400 ADDM A,XXX2
98500 ADDM A,XXX3
98600 ADDM A,XXX4
98700 ADDM A,XXX5
98800 MOVE A,GCP1
98900 HRRZM A,FWSO
99000 MOVE A,C3GCS
99100 HRRZM A,EFWSO#
99200 OUTALC: CLEARB F,DDTIFG
99300 JSP R,IOBRST
99400 JRST START
99500
99600
99700
99800
99900
00100
00200 ;SUBROUTINE FOR NUMBER INPUT
00300
00400
00500 ALLNUM: MOVEI A,0
00600 SKIPE NOALIN#
00700 JRST (R)
00800 INCHRW C
00900 CAIN C,RUBOUT
01000 JRST [OUTSTR [ASCIZ /XXX /]
01100 JRST ALLNUM]
01200 CAIL C,"0"
01300 CAILE C,"9"
01400 JRST BANGCK
01500 ASH A,3
01600 ADDI A,-"0"(C)
01700 JRST ALLNUM+3
01800
01900 BANGCK: CAIE C,LF
02000 JRST (R)
02100 SETOM NOALIN#
02200 JRST (R)
02300
02400 ;RETURNS 0 IF NOALIN # 0
02500 ;SETS NOALIN # 0 IF IT GETS A LINE FEED INPUT
02600
02700
02800
02900 PAGE
03000
03100
03200
03300
03400 IFN HASH,<
03500 REHASH:
03600 MOVEI A,BFWS(S)
03700 PUSH P,A
03800 HRRM A,RHX2
03900 HRRM A,RHX5
04000 MOVS B,RH4#
04100 ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
04200 ;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
04300 ;$$IN THE NEXT THREE FOO'S
04400
04500 HRRZI A,BFWS+1(B)
04600 MOVEM A,BFWS(B)
04700 AOBJN B,.-2
04800 SETZM BFWS(B)
04900 MOVSI AR2A,-BCKETS
05000 HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
05100 ;$$DOUBLE INDEXING WITH S IN REMOVING FOO
05200 ;$$PROBLEM
05300 RH1:
05400 HLRZ C,OBTBL(AR2A)
05500 RH3: JUMPE C,RH2
05600 HLRZ A,(C)
05700 PUSH P,C
05800 PUSH P,AR2A
05900 PUSHJ P,INTERN
06000 POP P,AR2A
06100 POP P,C
06200 HRRZ C,(C)
06300 JRST RH3
06400 RH2: AOBJN AR2A,RH1
06500 SETZM HASHFG
06600 POP P,A
06700 HRRM A,@GCP3
06800 MOVEM A,OBLIST(S)
06900 JRST START>
07000
07100 PAGE
07200 SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
07300
07400 ;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
07500 SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
07600 ADD A,SPNM
07700 POPJ P, ;$$
07800
07900
08000 ;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
08100 SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
08200 HLRE A,(A) ;$$GET LEFT HAND ITEM
08300 JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
08400 ;$$POINTER AND WE RETURN T INSTEAD
08500 HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
08600 POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
08700
08800 ;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
08900 SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
09000 HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
09100 POPJ P, ;$$
09200
09300 ;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
09400 NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
09500 HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
09600
09700 SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
09800 JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
09900 HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
10000 TLZE A,-1 ;$$
10100 SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
10200 ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
10300 POPJ P, ;$$
10400
10500
10600 ;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
10700 ;$$ MORE EFFICIENT THAN EVAL WITH ALIST
10800 EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
10900 PUSHJ P,ATOM ;$$
11000 EXCH A,C ;$$
11100 SUB B,SPNM ;$$
11200 EVALV1: CAIN B,(SP) ;$$CHECK FOR END OF SPDL
11300 JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
11400 SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
11500 AOJA B,EVALV1 ;$$
11600 HLRZ T,(B) ;$$T←CAR(B)
11700 SKIPE C ;$$
11800 HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
11900 CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
12000 AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
12100 HRRZ A,(B) ;$$GET VALUE FROM SPDL
12200 POPJ P, ;$$
12300
12400 GETV: JUMPE C,GETV1
12500 MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
12600 PUSHJ P,GET ;$$
12700 JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
12800 GETV1: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
12900 POPJ P, ;$$
13000
13100 UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
13200 POPJ P, ;$$
13300
13400 ;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
13500 CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
13600 HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
13700 ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
13800 ADD B,SC2 ;$$
13900 HRL B,TT ;$$SET UP SPD POINTER
14000 JRST UBD ;$$UBD DOES ALL THE WORK
14100
14200 ;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
14300 ;$$EVAL BLIP, WITH A GIVEN VALUE
14400 OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
14500 JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
14600 HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
14700 JRST SPRE1 ;$$ FINISH UP IN SPREDO
14800
14900
15000 ;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
15100 ;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
15200 REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
15300 HRRZ T,C2# ;$$
15400 HLRZ TT,C2# ;$$
15500 ADD TT,P ;$$
15600 SUB TT,T ;$$
15700 HRL P,TT ;$$
15800 DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
15900 SKIPE D ;$$DONE IF EMPTY
16000 CAMG D,P ;$$ COMPARE TO CURRENT RPDL
16100 XCT C ;$$ DONE, DO A STRANGE EXIT
16200 SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
16300 POP D,ERRSW ;$$
16400 POP D,ERRTN ;$$
16500 SUB D,[XWD 2,2] ;$$ SKIP PROG JUNK
16600 JRST DOSET ;$$ TRY AGAIN
16700
16800
16900
17000 ;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
17100 ;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
17200
17300 SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
17400 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
17500 MOVE B,A ;$$GET THE EXPRESSION
17600 SUB B,SPNM
17700 HRRZ B,(B)
17800 MOVE C,[JRST EVAL] ;$$SET RETURN
17900 SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
18000 PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
18100 POP P,A ;$$
18200 JRST REVAL1
18300
18400 ;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
18500 ;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
18600 ;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
18700 ;
18800 SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
18900 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
19000 JRST SPRE1-1 ;$$LET SPREDO FINISH UP
19100
19200
19300 ;$$COMPUTES A LISP POINTER TO A STACK ENTRY
19400 STKPTR: SUB A,SPNM
19500 POPJ P,
19600
19700 LALL
19800 PAGE
19900 SUBTTL LOW SETMENT INCLUDING REMOTE CODE
20000 RELOC 0
20100 HERE
20200 VAR
20300 XALL
20400 PAGE
20500 SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
20600 FS:
20700
20800 DEFINE MAKBUC (A,%B)
20900 <DEFINE OBT'A <%B=.>
21000 XWD %B,IFN <<BCKETS-1>-A>,<.+1>
21100 IF1 <%B=0>>
21200
21300 DEFINE ADDOB (A,C,%B)
21400 <OBT'A
21500 DEFINE OBT'A<%B=.>
21600 IF1 <%B=0>
21700 XWD C,%B>
21800
21900 DEFINE PUTOB (A,B)
22000 <ZZ==<ASCII +A+>←<-1>
22100 ZZ==-ZZ/BCKETS*BCKETS+ZZ
22200 ADDOB \ZZ,B>
22300
22400 DEFINE PSTRCT (A)
22500 <ZZ==[ASCII +A+]
22600 LENGTH(ZY,<A>)
22700 ZY==<ZY-1>/5
22800 Q1(ZY,ZZ)
22900 >
23000
23100 DEFINE Q1 (N,Z)<
23200 IFN N,<XWD Z,[Q1(N-1,Z+1)]>
23300 IFE N,<XWD Z,0>>
23400 DEFINE MKAT (A,B,C,D)
23500 <XLIST
23600 IRP A< PUTOB A,.+1
23700 D XWD -1,.+1
23800 XWD B,.+1
23900 XWD C'A,.+1
24000 XWD PNAME,.+1
24100 XWD [PSTRCT(A)],0>
24200 LIST>
24300
24400 DEFINE MKAT1 (A,B,C,D)
24500 <XLIST
24600 IRP C <PUTOB C,.+1
24700 XWD -1,.+1
24800 XWD B,.+1
24900 XWD D'A,.+1
25000 XWD PNAME,.+1
25100 XWD [PSTRCT(C)],0>
25200 LIST>
25300 DEFINE LENGTH (A,B)
25400 <A==0
25500 IRPC B,<A==A+1>>
25600 DEFINE ML1 (A)<IRP A,<
25700 V'A: XWD -1,.+1
25800 XWD FIXNUM,[A]
25900 MKAT A,SYM,V
26000 >>
26100
26200 DEFINE MKSY1 (A,B,%C)<
26300 XLIST
26400 %C: XWD -1,.+1
26500 XWD FIXNUM,[A]
26600 PUTOB B,.+1
26700 XWD -1,.+1
26800 XWD SYM,.+1
26900 XWD %C,.+1
27000 XWD PNAME,.+1
27100 XWD [PSTRCT(B)],0
27200 LIST>
27300
27400 DEFINE ML (A)<
27500 XLIST
27600 IRP A,<PUTOB A,.+1
27700 A: XWD -1,.+1
27800 XWD PNAME,.+1
27900 XWD [PSTRCT(A)],0>
28000 LIST>
28100 DEFINE MK (A)<
28200 XLIST
28300 IRP A,<PUTOB A,.+1
28400 XWD -1,.+1
28500 XWD PNAME,.+1
28600 XWD [PSTRCT(A)],0>
28700 LIST>
28800
28900 OBTBL:
29000 OBLIST: ZZ==0
29100 XLIST
29200 REPEAT BCKETS,<MAKBUC \ZZ
29300 ZZ==ZZ+1>
29400 LIST
29500
29600 PAGE
29700 MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
29800 MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
29900 MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
30000 MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
30100 MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
30200 MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
30300 MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
30400 MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
30500 MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
30600 MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
30700 MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
30800 MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
30900 MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
31000 IFN STPGAP,<MAKAT<PGLINE>,SUBR>
31100
31200 MKAT EXPLODEC,SUBR,%
31300 MKAT TAB,SUBR,.
31400 MKAT TYO,SUBR,I
31500 MKAT TYI,SUBR,I
31600 CEVAL=.+1
31700 MKAT1 EVAL,SUBR,*EVAL
31800
31900 ;$$ REDEF. FOR NEW MAP FUNCTIONS
32000 MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
32100 ;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
32200 MKAT1 MAPCAN,LSUBR,MAPCONC
32300
32400 PROGAT: MKAT<PROG>,FSUBR
32500
32600 MKAT <PROGN,LIST,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
32700 IFN ALVINE,<MKAT<GRINDEF>,FSUBR
32800 MKAT<ED>,SUBR>
32900 IFE ALVINE,<MK<GRINDEF>>
33000 MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
33100 MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
33200 MKAT1 QUOTE,FSUBR,FUNCTION
33300 MKAT1 %CLRBFI,SUBR,CLRBFI
33400 MKAT1 .ERROR,SUBR,ERROR
33500 MKAT1 LINRD,SUBR,LINEREAD
33600 MKAT1 UNBOND,SUBR,UNBOUND
33700 MKAT1 ECHO,SUBR,TTYECHO
33800 MKAT1 FUNCT,FSUBR,*FUNCTION
33900 MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
34000
34100 MKAT EVAL,LSUBR,O
34200 MKAT ASCII,SUBR,A
34300 MKAT QUOTE,FSUBR,,CQUOTE:
34400 MKAT INUM0,SYM
34500
34600 PUTOB T,.+1
34700 TRUTH: XWD -1,.+1
34800 XWD VALUE,.+1
34900 XWD VTRUTH,.+1
35000 XWD PNAME,.+1
35100 XWD [PSTRCT(T)],0
35200 VTRUTH: TRUTH
35300
35400 PUTOB NIL,0
35500 CNIL2: XWD VALUE,.+1
35600 XWD VNIL,.+1
35700 XWD PNAME,.+1
35800 XWD [PSTRCT(NIL)],0
35900 VNIL: NIL
36000 MKSY1 %LCALL,*LCALL
36100 MKSY1 %AMAKE,*AMAKE
36200 MKSY1 %UDT,*UDT
36300 MKSY1 .MAPC,*MAPC
36400 MKSY1 .MAP,*MAP
36500 MKAT1 %NOPOINT,VALUE,*NOPOINT
36600 %NOPOINT: NIL
36700
36800
36900 UNBOUND: XWD -1,.+1
37000 XWD PNAME,.+1
37100 XWD [PSTRCT(UNBOUND)],0
37200 PAGE
37300 MKAT1 EXPN1,SUBR,*EXPAND1
37400 MKAT1 EXPAND,SUBR,*EXPAND
37500 MKAT1 PLUS,SUBR,*PLUS,.
37600 MKAT1 DIF,SUBR,*DIF,.
37700 MKAT1 QUO,SUBR,*QUO,.
37800 MKAT1 TIMES,SUBR,*TIMES,.
37900 MKAT1 APPEND,SUBR,*APPEND,.
38000 MKAT1 RSET,SUBR,*RSET,.
38100 MKAT1 GREAT,SUBR,*GREAT,.
38200 MKAT1 LESS,SUBR,*LESS,.
38300 MKAT1 PUTSYM,SUBR,*PUTSYM
38400 MKAT1 GETSYM,SUBR,*GETSYM
38500
38600 ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
38700
38800 PUTOB NUMVAL,.+1
38900 XWD -1,.+1
39000 XWD SUBR,.+1
39100 XWD NUMVAL,.+1
39200 XWD SYM,.+3
39300 XWD FIXNUM,[NUMVAL]
39400 XWD -1,.-1
39500 XWD .-1,.+1
39600 XWD PNAME,.+1
39700 XWD [PSTRCT(NUMVAL)],0
39800
39900 MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
40000
40100 ;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
40200
40300 ML ERRORX
40400 MKAT1 INTPRP,SUBR,INITPROMPT
40500 MKAT1 LSPRET,FSUBR,**TOP**
40600 MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
40700 MKAT<MEMB,NEXTEV>,SUBR
40800 MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
40900 MKAT<EVALV,OUTVAL>,SUBR
41000
41100 ;$$ MORE EXTENSIONS INCLUDING READ MACROS
41200 ML READMACRO
41300 MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
41400 MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,COPY,LEXORDER>,SUBR
41500 MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
41600 MKAT1 FALSE,FSUBR,SPECIAL
41700 MKAT1 FALSE,FSUBR,NOCALL
41800 MKAT1 FALSE,FSUBR,DECLARE
41900 MKAT1 FALSE,FSUBR,NILL
42000 MKAT1 APPLY.,SUBR,APPLY#
42100 MKAT1 .MAX,SUBR,*MAX
42200 MKAT1 .MIN,SUBR,*MIN
42300 MKAT1 MEMBR.,SUBR,MEMBER#
42400 MKAT1 MEMB,SUBR,MEMQ#
42500 MKAT1 AND.,FSUBR,AND#
42600 MKAT1 OR.,FSUBR,OR#
42700
42800 ;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
42900 MKAT1 BIOCHN,VALUE,#%IOCHANS%#
43000 MKAT1 BPMPT,VALUE,#%PROMPTS%#
43100 MKAT1 BINDNT,VALUE,#%INDENT
43200 BIOCHN: NIL
43300 BPMPT: NIL
43400 BINDNT: INUM0
43500
43600 VOBLIST: OBLIST
43700 VBASE: 8+INUM0
43800 VIBASE: 8+INUM0
43900
44000 ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
44100 $EOF$,LABEL,FUNARG,LSUBR,MACRO>
44200
44300 PUTOB ?,.+1
44400 QST: XWD -1,.+1
44500 XWD PNAME,.+1
44600 XWD [PSTRCT(?)],0
44700
44800 VBPORG: INUM0
44900 VBPEND: INUM0
45000
45100 ;MKAT ACHLOC,SYM
45200 ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
45300
45400 PAGE
45500 ;
45600 ; ALL THE ATOMS IN THE WHOLE SYSTEM
45700 MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
45800 MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
45900 MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
46000 MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
46100 MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
46200 MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
46300 MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
46400 MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
46500 MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
46600 MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
46700 MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
46800 MK<EDITE,EDITF,EDITFNS,EDITFPAT>
46900 MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
47000 MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
47100 MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
47200 MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
47300 MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
47400 MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
47500 MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
47600 MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
47700 MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
47800 MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
47900 MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
48000 MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
48100 MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
48200 MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
48300 MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
48400 MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO>
48500 MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
48600 MK<START,STKCOUNT,STKNAME,STKNTH>
48700 MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
48800 MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
48900 MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
49000 MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
49100 MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
49200 MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
49300 MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, , , ?, . ,< . UNBOUND)>>
49400 MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
49500 MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
49600 MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
49700 MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
49800 MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
49900 MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
50000 MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
50100 MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
50200 MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
50300 MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
50400 MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
50500 MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
50600 MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
50700 MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
50800 MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
50900
51000 ;ATOMS OF GENERATED FUNCTIONS
51100 MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
51200 MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
51300 BFWS:
51400 EFWS: 0
51500 RELOC
51600 XLIST
51700 LIT
51800 LIST
51900 BHORG: 0
52000 RELOC
52100 PAGE
52200 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
52300
52400
52500 ALLOC: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
52600 HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
52700 HRRZM A,SFS
52800 HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
52900 HRRZM A,SFWS ;FWS
53000 HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
53100 HRRZM A,SSPDL
53200 HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
53300 HRRZI A,FS
53400 HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
53500 HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
53600 HRRZM A,FWSO#
53700
53800 HRRZI A,EFWS
53900 HRRZM A,EFWSO#
54000
54100
54200 MOVEI A,FS
54300 ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
54400 SOS A
54500 ADDM A,VBPEND
54600
54700 MOVE A,JOBREL
54800 HRLM A,JOBSA
54900 CALLI RESET
55000 MOVEI A,DDT
55100 CALLI A,2 ;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
55200 MOVEI A,LISPGO
55300 HRRM A,JOBSA
55400
55500 SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
55600 SETZM JRELO# ;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
55700
55800 JRST INALLC
55900
56000
56100 DEFINE MKENT (A)<
56200 INTERNAL A>
56300
56400 MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
56500 MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
56600 MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
56700 MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
56800 MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
56900 MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
57000 MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
57100 MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
57200 MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
57300 MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
57400 IFN ALVINE,<MKENT<PSAV1,BKTRC>>
57500
57600 ;$$ FOR ALAN'S DIRECT ACCESS INPUT
57700 MKENT <ININBF,TYI2,TYIA,INCH>
57800
57900 ;$$ FOR ALVINE
58000 MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
58100
58200 PAGE
58300 END ALLOC
58400